diff --git a/base/comm/internals/psi_covrl_restr.f90 b/base/comm/internals/psi_covrl_restr.f90 index 9e1c86358..26eebae95 100644 --- a/base/comm/internals/psi_covrl_restr.f90 +++ b/base/comm/internals/psi_covrl_restr.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_covrl_restr_a.f90 b/base/comm/internals/psi_covrl_restr_a.f90 index 6d4a4cad6..79bc92c73 100644 --- a/base/comm/internals/psi_covrl_restr_a.f90 +++ b/base/comm/internals/psi_covrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_covrl_save.f90 b/base/comm/internals/psi_covrl_save.f90 index 5891a202b..d2583fb04 100644 --- a/base/comm/internals/psi_covrl_save.f90 +++ b/base/comm/internals/psi_covrl_save.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_covrl_save_a.f90 b/base/comm/internals/psi_covrl_save_a.f90 index c50676e83..3da176a3e 100644 --- a/base/comm/internals/psi_covrl_save_a.f90 +++ b/base/comm/internals/psi_covrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_covrl_upd.f90 b/base/comm/internals/psi_covrl_upd.f90 index 28a7d1077..43841f5d5 100644 --- a/base/comm/internals/psi_covrl_upd.f90 +++ b/base/comm/internals/psi_covrl_upd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_covrl_upd_a.f90 b/base/comm/internals/psi_covrl_upd_a.f90 index f2f2df08e..7e53fe66a 100644 --- a/base/comm/internals/psi_covrl_upd_a.f90 +++ b/base/comm/internals/psi_covrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index cf6733223..72b97a987 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -41,7 +41,7 @@ ! 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_) +! D complex(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -53,31 +53,22 @@ ! is scattered in the owned indices, and BETA=1. ! The first routine picks the desired exchange index list and passes it to the second. ! This version works on encapsulated vectors, and uses their methods to do GTH and SCT, -! so that special versions (i.e. GPU vectors can override them +! so that special versions (i.e. GPU vectors can override them) ! ! 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) +! swap_status - integer Swap status selector. +! It is interpreted as a communication status: +! psb_comm_status_start_ -> START phase +! psb_comm_status_wait_ -> WAIT phase +! psb_comm_status_unknown_ -> START+WAIT +! The communication scheme is selected from +! y%comm_handle%comm_type. ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. +! beta - real Choose overwrite or sum. ! y - type(psb_@x@_vect_type) The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! our own internal allocation. +! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -91,9 +82,16 @@ submodule (psi_c_comm_v_mod) psi_c_swapdata_impl use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_ use psb_base_mod + use psb_error_mod, only: psb_get_debug_level, psb_get_debug_unit, psb_debug_ext_ + 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_, & + & psb_comm_handle_type + use psb_comm_rma_mod, only: psb_comm_rma_handle + use psb_comm_factory_mod + contains - module subroutine psi_cswapdata_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_cswapdata_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -102,23 +100,24 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - class(psb_c_base_vect_type), intent(inout) :: y - complex(psb_spk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ + 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 + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent - character(len=30) :: name + ! error handling variables + integer(psb_ipk_) :: err_act + character(len=30) :: name info = psb_success_ name = 'psi_cswapdata_vect' @@ -126,14 +125,14 @@ contains ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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 + if (.not.psb_is_asb_desc(desc_a)) then info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 @@ -145,156 +144,209 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if + + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if - 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') + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_cswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) then + + 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) + 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_cswap_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') + case(psb_comm_ineighbor_alltoallv_) + call psi_cswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') goto 9999 end if - else + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_cswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_cswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_cswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') goto 9999 - end if + end select call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return end subroutine psi_cswapdata_vect - subroutine psi_cswap_baseline_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_cswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! 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_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& - & 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 + & snd_pt, rcv_pt, pnti, n + logical :: do_send,do_recv + logical, parameter :: usersend=.false. + logical :: debug + character(len=20) :: name info = psb_success_ name = 'psi_cswap_baseline_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv + do_send = (swap_status == psb_comm_status_start_).or.(swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_).or.(swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n - call idx%sync() + call comm_indexes%sync() - if (debug) write(*,*) me,'Internal buffer' + if (debug) write(*,*) my_rank,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) + call psb_errpush(info,name,a_err='Unfinished communication? Something is wrong....') 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(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(comm_indexes%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' Gather ' + if (debug) write(*,*) my_rank,' Gather ' ! ! Then gather for sending. ! pnti = 1 do i=1, num_neighbors - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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) + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(idx_pt,nesd,comm_indexes) pnti = pnti + nerv + nesd + 3 end do @@ -303,7 +355,7 @@ contains ! call y%device_wait() - if (debug) write(*,*) me,' isend' + if (debug) write(*,*) my_rank,' isend' ! ! Then send ! @@ -311,18 +363,18 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((nesd>0).and.(proc_to_comm /= my_rank)) then call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -336,8 +388,8 @@ contains end if if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -347,19 +399,19 @@ contains end if call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' pnti = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 (proc_to_comm /= my_rank)then if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -367,59 +419,73 @@ contains end if end if if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%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 + else if (proc_to_comm == my_rank) then if (nesd /= nerv) then write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd + & '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 - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' scatter' + if (debug) write(*,*) my_rank,' scatter' pnti = 1 snd_pt = 1 rcv_pt = 1 do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((idx_pt < 1) .or. (nerv < 0) .or. (idx_pt+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + + if (debug) write(*,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 end do + ! ! Waited for everybody, clean up ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device ! - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' + if (debug) write(*,*) my_rank,' free buffer' call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) + if (info == 0) then + if (allocated(y%comm_handle)) call y%comm_handle%free(info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if - if (debug) write(*,*) me,' done' + if (debug) write(*,*) my_rank,' done' end if @@ -432,39 +498,41 @@ contains end subroutine psi_cswap_baseline_vect - subroutine psi_cswap_neighbor_topology_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_cswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name - + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_cswap_nbr_vect' + name = 'psi_cswap_neighbor_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -473,97 +541,179 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - call idx%sync() + call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if (buffer_size > 0) then + 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 + neighbor_comm_handle%comm_request = mpi_request_null + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%comm_request = mpi_request_null end if - y%communication_handle = mpi_request_null - - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + ! Wait for device (important for GPU subclasses) call y%device_wait() - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_c_spk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_c_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + ! Post non-blocking neighborhood alltoallv + 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, & + & neighbor_comm_handle%comm_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null end if - end if + end if ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%comm_request = mpi_request_null + else + if (neighbor_comm_handle%comm_request == mpi_request_null) then + write(psb_err_unit,*) my_rank, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', & + & neighbor_comm_handle%is_initialized + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + 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,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((1+pnti+psb_n_elem_recv_ < 1) .or. (nerv < 0) .or. & + & (1+pnti+psb_n_elem_recv_+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 + end do + else + ! nothing to wait/scatter end if - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) - y%communication_handle = mpi_request_null + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_vect: done' + if (debug) write(*,*) my_rank,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -573,103 +723,252 @@ contains return end subroutine psi_cswap_neighbor_topology_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,info,data) + + + subroutine psi_cswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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 - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta - class(psb_c_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data - - ! 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 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - 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 + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_cswapdata_multivect' + name = 'psi_cswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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 + icomm = ctxt%get_mpic() - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swap') + goto 9999 + end select - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') goto 9999 end if - 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 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - 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 + call comm_indexes%sync() - if (baseline) then - call psi_cswap_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') + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') goto 9999 end if - else if (neighbor_a2av) then - call psi_cswap_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 + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if 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 + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into combuf using baseline-style gth calls + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data (baseline layout),', topology_total_send,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Lazy persistent-init: build the request once, then reuse with START/WAIT. + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (baseline-style sct) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data (baseline layout),', topology_total_recv,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + rcv_pt = 1+pnti+psb_n_elem_recv_ + if (nerv > 0) then + call y%sct(rcv_pt,nerv,comm_indexes,beta) + end if + pnti = pnti + nerv + nesd + 3 + end do + end if + + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -677,11 +976,10 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_cswapdata_multivect + end subroutine psi_cswap_neighbor_persistent_topology_vect - subroutine psi_cswap_baseline_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_cswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -689,242 +987,512 @@ contains #ifdef PSB_MPI_H include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_) :: beta - class(psb_c_base_multivect_type) :: y - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv - integer(psb_ipk_), intent(out) :: info - ! 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, total_send_, total_recv_,& - & 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' + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n + + + info = psb_success_ + name = 'psi_cswap_rma_pull_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 - endif + end if icomm = ctxt%get_mpic() - n = y%get_ncols() + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select - 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 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - total_recv_ = total_recv * n - total_send_ = total_send * n + call comm_indexes%sync() - call idx%sync() + ! START phase: build the layout once, prepare the exposed buffer, then issue RMA. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if - 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/)) + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') 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(num_neighbors,info) - y%comid = mpi_request_null - call psb_realloc(num_neighbors,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - do i=1, num_neighbors - 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 = total_recv_+1 - rcv_pt = 1 - do i=1, num_neighbors - 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 = total_recv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, num_neighbors - 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) + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Expose combuf once and keep the window around until the descriptor changes. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, 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 + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if ((recv_pos < 1) .or. (recv_count < 0) .or. (recv_pos+max(0,recv_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull local receive bounds error') + goto 9999 + end if + + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if 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 + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) end if - call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, num_neighbors - 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 y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_cswap_rma_pull_vect + + + subroutine psi_cswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_cswap_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! START phase: identical layout handling, but the remote metadata describes the receive side. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_open = .false. 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_ + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null 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 + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(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 + end if - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - do i=1, num_neighbors - 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 ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Keep the window alive across repetitions: it is created once and reused. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if - 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 + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() - ! - ! 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 + ! Pre-post notification receives before opening the window (prevents isend/irecv ordering issues). + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push data to each peer; after flush send a P2P notification so target knows data arrived. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if ((send_pos < 1) .or. (send_count < 0) .or. (send_pos+max(0,send_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push local send bounds error') + goto 9999 + end if + + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_spk_, prc_rank, remote_disp, send_count, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do end if - if (debug) write(*,*) me,' done' end if + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if + + call y%device_wait() + end if call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return - end subroutine psi_cswap_baseline_multivect + end subroutine psi_cswap_rma_push_vect - subroutine psi_cswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + ! + ! + ! Subroutine: psi_cswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_cswapdata_multivect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -933,126 +1501,131 @@ contains include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_multivect_type), intent(inout) :: y - complex(psb_spk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + integer(psb_ipk_), intent(in) :: swap_status + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act + integer(psb_mpk_) :: n, total_send_, total_recv_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name + + info = psb_success_ - name = 'psi_cswap_neighbor_topology_multivect' + name = 'psi_cswapdata_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif - icomm = ctxt%get_mpic() - - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - call idx%sync() + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if - if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') - goto 9999 - end if - end if + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - buffer_size = topology_total_send + topology_total_recv + if ((swap_status /= psb_comm_status_start_) .and. (swap_status /= psb_comm_status_wait_) & + & .and. (swap_status /= psb_comm_status_unknown_)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 end if - y%communication_handle = mpi_request_null + end if - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') + goto 9999 + end if - call y%device_wait() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_c_spk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_c_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) + baseline = .false. + ineighbor_a2av = .false. + ineighbor_a2av_persistent = .false. + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + ineighbor_a2av = .true. + case(psb_comm_persistent_ineighbor_alltoallv_) + ineighbor_a2av_persistent = .true. + case(psb_comm_rma_pull_) + call psi_cswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') goto 9999 end if - - end if - - if (do_wait) then - - if (y%communication_handle == mpi_request_null) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) + case(psb_comm_rma_push_) + call psi_cswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') goto 9999 end if + case default + baseline = .true. + end select - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) + if (baseline) then + call psi_cswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') goto 9999 end if - - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) - - y%communication_handle = mpi_request_null - call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + else if (ineighbor_a2av) then + call psi_cswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') goto 9999 end if - if (debug) write(*,*) me,' nbr_vect: done' - + else if (ineighbor_a2av_persistent) then + call psi_cswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') + goto 9999 end if call psb_erractionrestore(err_act) @@ -1061,7 +1634,1112 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_cswap_neighbor_topology_multivect + end subroutine psi_cswapdata_multivect + + + + +subroutine psi_cswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti + logical :: do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info = psb_success_ + name = 'psi_cswap_baseline_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swap') + goto 9999 + end select + + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + total_recv_ = total_recv * n + total_send_ = total_send * n + + call comm_indexes%sync() + + if (debug) write(*,*) my_rank,'Internal buffer' + if (do_send) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) my_rank,'do_send start' + call y%new_buffer(total_send_+total_recv_,info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + baseline_comm_handle%comid = mpi_request_null + call psb_realloc(num_neighbors,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'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,baseline_comm_handle%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(*,*) my_rank,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,comm_indexes) + 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(*,*) my_rank,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= my_rank)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%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 (do_recv) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%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(num_neighbors,prcid,info) + + if (debug) write(*,*) my_rank,' wait' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= my_rank)then + if (nesd>0) then + call mpi_wait(baseline_comm_handle%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 + if (nerv>0) then + call mpi_wait(baseline_comm_handle%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 == my_rank) 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 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) my_rank,' scatter' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,comm_indexes,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 + ! + baseline_comm_handle%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) my_rank,' wait' + call y%device_wait() + if (debug) write(*,*) my_rank,' free buffer' + call y%free_buffer(info) + if (info == 0) then + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_cswap_baseline_multivect + + + +subroutine psi_cswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_cswap_neighbor_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (buffer_size > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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 + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + if ((topology_total_send + topology_total_recv) > 0) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Wait for the non-blocking collective to complete + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, 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 + + ! Scatter received data to local vector positions (polymorphic for GPU) + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + end if + + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_cswap_neighbor_topology_multivect + + + +subroutine psi_cswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_cswap_neighbor_topology_multivect_persistent' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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 + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) > 0) then + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_cswap_neighbor_topology_multivect_persistent + + + subroutine psi_cswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_cswap_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_cswap_rma_pull_multivect + + + subroutine psi_cswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_cswap_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_cswap_rma_push_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 709a0d629..cab18b2be 100644 --- a/base/comm/internals/psi_cswapdata_a.F90 +++ b/base/comm/internals/psi_cswapdata_a.F90 @@ -39,7 +39,7 @@ ! 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_) +! D complex(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -70,10 +70,10 @@ ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:,:) - complex The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do +! 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 @@ -97,13 +97,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -165,12 +166,13 @@ complex(psb_spk_), target :: work(:) #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n 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 + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -293,8 +295,8 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_spk_,icomm,iret) + & 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/)) @@ -348,9 +350,9 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + n*nerv @@ -370,15 +372,15 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag + 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_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,iret) else call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,iret) end if @@ -401,7 +403,7 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -510,7 +512,7 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf ! 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_) + ! D complex(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -541,10 +543,10 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf ! ! ! n - integer Number of columns in Y - ! beta - complex Choose overwrite or sum. - ! y(:) - complex The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - complex Buffer space. If not sufficient, will do + ! 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 @@ -565,12 +567,13 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + integer(psb_ipk_), intent(in) :: flag + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -648,7 +651,8 @@ 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_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -775,8 +779,8 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_spk_,icomm,iret) + & 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/)) @@ -830,9 +834,9 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + nerv @@ -852,16 +856,16 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag + 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_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,iret) else call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,iret) end if @@ -882,7 +886,7 @@ complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index 8c233e17e..ca390eccd 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -43,7 +43,7 @@ ! 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_) +! D complex(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -59,12 +59,12 @@ ! ! ! Arguments: -! flag - integer Choose the algorithm for data exchange: +! swap_status - 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 +! swap_mpi = iand(swap_status,psb_swap_mpi_) /= 0 +! swap_sync = iand(swap_status,psb_swap_sync_) /= 0 +! swap_send = iand(swap_status,psb_swap_send_) /= 0 +! swap_recv = iand(swap_status,psb_swap_recv_) /= 0 ! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_sync): use PSB_SND and PSB_RCV in ! synchronized pairs @@ -77,8 +77,8 @@ ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y - type(psb_c_vect_type) The data area +! beta - real Choose overwrite or sum. +! y - type(psb_d_vect_type) The data area ! desc_a - type(psb_desc_type). The communication descriptor. ! our own internal allocation. ! info - integer. return code. @@ -92,8 +92,9 @@ ! submodule (psi_c_comm_v_mod) psi_c_swaptran_impl use psb_base_mod + use psb_comm_factory_mod contains - module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_cswaptran_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -103,23 +104,19 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta - class(psb_c_base_vect_type), intent(inout) :: y - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ - 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 - logical :: baseline, neighbor_a2av + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=20) :: name info = psb_success_ name = 'psi_cswaptran_vect' @@ -152,40 +149,64 @@ contains goto 9999 end if + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - 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 + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if - 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') + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_ctran_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_ctran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + call psb_errpush(info,name,a_err='neighbor a2av tran') goto 9999 end if - else if (neighbor_a2av) then - call psi_ctran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_ctran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + call psb_errpush(info,name,a_err='persistent neighbor tran') 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 + case(psb_comm_rma_pull_) + call psi_ctran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_ctran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_ctran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -197,7 +218,7 @@ contains ! ! - ! Subroutine: psi_ctran_vidx_vect + ! Subroutine: psi_ctran_baseline_vect ! Data exchange among processes. ! ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods @@ -208,8 +229,9 @@ contains ! ! ! - module subroutine psi_ctran_baseline_vect(ctxt,flag,beta,y,idx,& - & num_neighbors,total_send,total_recv,info) + module subroutine psi_ctran_baseline_vect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) + #ifdef PSB_MPI_MOD use mpi #endif @@ -219,11 +241,12 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals @@ -231,6 +254,7 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_) :: icomm integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& @@ -249,13 +273,19 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n @@ -264,8 +294,8 @@ contains if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -276,12 +306,12 @@ contains end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) @@ -294,7 +324,7 @@ contains 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do @@ -330,7 +360,7 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) @@ -341,7 +371,7 @@ contains 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -356,7 +386,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -368,7 +398,7 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) @@ -378,7 +408,7 @@ contains if (proc_to_comm /= me)then if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -386,7 +416,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -424,7 +454,7 @@ contains ! ! Waited for everybody, clean up ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -433,7 +463,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -453,29 +485,31 @@ contains - subroutine psi_ctran_neighbor_topology_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_ctran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: idx + class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. @@ -483,9 +517,9 @@ contains info = psb_success_ - name = 'psi_cswap_trn_nbr_vect' + name = 'psi_ctran_neighbor_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -494,17 +528,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swaptran') + goto 9999 + end select - call idx%sync() + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -512,8 +559,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -521,70 +572,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_vect: gathering (recv) data,', topology_total_recv,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_c_spk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & & psb_mpi_c_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_vect: scattering (send) data,', topology_total_send,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_vect: done' + if (debug) write(*,*) me,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -594,7 +656,9 @@ contains return end subroutine psi_ctran_neighbor_topology_vect - + + + ! ! ! @@ -605,7 +669,7 @@ contains ! Takes care of Y an encaspulated multivector. ! ! - module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,info,data) + module subroutine psi_cswaptran_multivect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -615,8 +679,8 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_multivect_type), intent(inout) :: y type(psb_desc_type),target :: desc_a integer(psb_ipk_), intent(out) :: info @@ -629,9 +693,8 @@ contains 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 - logical :: baseline, neighbor_a2av + integer(psb_ipk_) :: setflag + info = psb_success_ name = 'psi_cswaptran_multivect' @@ -641,7 +704,7 @@ contains icomm = ctxt%get_mpic() call psb_info(ctxt,me,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif @@ -664,39 +727,73 @@ contains goto 9999 end if - 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 + setflag = swap_status + if (swap_status == psb_swap_start_) then + setflag = psb_comm_status_start_ + else if (swap_status == psb_swap_wait_) then + setflag = psb_comm_status_wait_ + else if ((iand(swap_status, psb_swap_send_) /= 0) .or. (iand(swap_status, psb_swap_recv_) /= 0) .or. & + & (iand(swap_status, psb_swap_mpi_) /= 0) .or. (iand(swap_status, psb_swap_sync_) /= 0)) then + setflag = psb_comm_status_sync_ + end if - if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + if ((setflag /= psb_comm_status_start_) .and. (setflag /= psb_comm_status_wait_) .and. & + & (setflag /= psb_comm_status_sync_)) then info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') + call psb_errpush(info,name,a_err='Invalid swap_status') goto 9999 end if - if (baseline) then - call psi_ctran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 end if - else if (neighbor_a2av) then - call psi_ctran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + end if + + call y%comm_handle%set_swap_status(setflag, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') + goto 9999 + end if + + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_ctran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + call psb_errpush(info,name,a_err='neighbor a2av tran') 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 + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_ctran_neighbor_persistent_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_ctran_rma_pull_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_ctran_rma_push_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_ctran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -706,22 +803,8 @@ contains return 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. - ! - ! - ! - module subroutine psi_ctran_baseline_multivect(ctxt,flag,beta,y,idx,& - & num_neighbors,total_send,total_recv,info) + subroutine psi_ctran_baseline_multivect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -732,18 +815,20 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info + class(psb_comm_handle_type), intent(inout) :: comm_handle ! 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(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& @@ -751,8 +836,8 @@ contains logical, parameter :: usersend=.false., debug=.false. character(len=20) :: name - info=psb_success_ - name='psi_swap_tran' + info = psb_success_ + name = 'psi_ctran_vidx_multivect' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then @@ -762,14 +847,20 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n @@ -778,8 +869,8 @@ contains if (debug) write(*,*) me,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -790,14 +881,14 @@ contains end if if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) @@ -807,7 +898,7 @@ contains 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -844,7 +935,7 @@ contains pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = idx%v(pnti+psb_proc_id_) nerv = idx%v(pnti+psb_n_elem_recv_) @@ -854,7 +945,7 @@ contains 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -870,7 +961,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -884,14 +975,14 @@ contains pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -899,7 +990,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -941,7 +1032,7 @@ contains ! ! Waited for com, cleanup comid ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -950,7 +1041,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -969,40 +1062,40 @@ contains end subroutine psi_ctran_baseline_multivect - - subroutine psi_ctran_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) - + subroutine psi_ctran_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta - class(psb_c_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name info = psb_success_ name = 'psi_ctran_neighbor_topology_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -1011,17 +1104,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swaptran') + goto 9999 + end select - call idx%sync() + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -1029,8 +1135,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -1038,70 +1148,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_vect: gathering (recv) data,', topology_total_recv,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_c_spk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & & psb_mpi_c_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_vect: scattering (send) data,', topology_total_send,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_vect: done' + if (debug) write(*,*) me,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -1111,6 +1232,1336 @@ contains return end subroutine psi_ctran_neighbor_topology_multivect -end submodule psi_c_swaptran_impl - + + subroutine psi_ctran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_ctran_neighbor_persistent_topology_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes (we "send" recv data) + if (debug) write(*,*) my_rank,' tran_persistent_vect: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv counts in alltoallv_init + ! send = recv_indexes data with recv_counts/displs + ! recv = into send_indexes area with send_counts/displs + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_c_spk_, & + & y%combuf(topology_total_recv + 1), & + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_c_spk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_vect: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_neighbor_persistent_topology_vect + + + subroutine psi_ctran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! Effective sizes for transpose: + ! eff_send = total_recv (we expose recv_indexes data) + ! eff_recv = total_send (we GET into the send_indexes area) + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ctran_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_rma_pull_vect + + + subroutine psi_ctran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ctran_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push our recv_indexes data to each peer's send_indexes area; notify after flush. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_spk_, prc_rank, remote_disp, send_count, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_rma_push_vect + + + subroutine psi_ctran_neighbor_persistent_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret, n + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_ctran_neighbor_persistent_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor multivect swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:total_recv_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv in alltoallv_init + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & psb_mpi_c_spk_, & + & y%combuf(total_recv_ + 1), & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_c_spk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(total_recv_+1:total_recv_+total_send_), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_neighbor_persistent_topology_multivect + + + subroutine psi_ctran_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ctran_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull multivect') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_rma_pull_multivect + + + subroutine psi_ctran_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ctran_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push multivect') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_rma_push_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 285a6a162..03f511975 100644 --- a/base/comm/internals/psi_cswaptran_a.F90 +++ b/base/comm/internals/psi_cswaptran_a.F90 @@ -30,7 +30,7 @@ ! ! ! -! File: psi_cswaptran.F90 +! File: psi_cswaptran_a.F90 ! ! Subroutine: psi_cswaptranm ! Implements the data exchange among processes. This is similar to Xswapdata, but @@ -43,7 +43,7 @@ ! 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_) +! D complex(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -74,10 +74,10 @@ ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:,:) - complex The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do +! 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 @@ -101,13 +101,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -149,7 +150,7 @@ contains goto 9999 end if - call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + 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) @@ -174,7 +175,8 @@ contains 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_), intent(inout) :: y(:,:) + complex(psb_spk_), intent(in) :: beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -305,8 +307,8 @@ contains ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) + & 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/)) @@ -360,9 +362,9 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + n*nerv @@ -383,14 +385,14 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,iret) else call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,iret) end if @@ -413,7 +415,7 @@ contains nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -525,7 +527,7 @@ contains ! 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_) + ! D complex(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -556,10 +558,10 @@ contains ! ! ! n - integer Number of columns in Y - ! beta - complex Choose overwrite or sum. - ! y(:) - complex The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - complex Buffer space. If not sufficient, will do + ! 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 @@ -579,12 +581,13 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -659,7 +662,8 @@ contains 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_), intent(inout) :: y(:) + complex(psb_spk_), intent(in) :: beta complex(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -791,8 +795,8 @@ contains ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) + & 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/)) @@ -845,9 +849,9 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + nerv @@ -868,14 +872,14 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag, icomm,iret) else call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& + & psb_mpi_r_spk_,prcid(i),& & p2ptag, icomm,iret) end if @@ -896,7 +900,7 @@ contains 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_dovrl_restr.f90 b/base/comm/internals/psi_dovrl_restr.f90 index 9bc9bed57..03e7a6209 100644 --- a/base/comm/internals/psi_dovrl_restr.f90 +++ b/base/comm/internals/psi_dovrl_restr.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_dovrl_restr_a.f90 b/base/comm/internals/psi_dovrl_restr_a.f90 index f197251ba..39a644864 100644 --- a/base/comm/internals/psi_dovrl_restr_a.f90 +++ b/base/comm/internals/psi_dovrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_dovrl_save.f90 b/base/comm/internals/psi_dovrl_save.f90 index 16b376608..b191d788c 100644 --- a/base/comm/internals/psi_dovrl_save.f90 +++ b/base/comm/internals/psi_dovrl_save.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_dovrl_save_a.f90 b/base/comm/internals/psi_dovrl_save_a.f90 index 25d754d09..a6950076a 100644 --- a/base/comm/internals/psi_dovrl_save_a.f90 +++ b/base/comm/internals/psi_dovrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_dovrl_upd.f90 b/base/comm/internals/psi_dovrl_upd.f90 index 147fa47a6..a3f54e098 100644 --- a/base/comm/internals/psi_dovrl_upd.f90 +++ b/base/comm/internals/psi_dovrl_upd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_dovrl_upd_a.f90 b/base/comm/internals/psi_dovrl_upd_a.f90 index 5b81d0963..a3e99bb6e 100644 --- a/base/comm/internals/psi_dovrl_upd_a.f90 +++ b/base/comm/internals/psi_dovrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index a19c17e39..922bff293 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -53,7 +53,7 @@ ! is scattered in the owned indices, and BETA=1. ! The first routine picks the desired exchange index list and passes it to the second. ! This version works on encapsulated vectors, and uses their methods to do GTH and SCT, -! so that special versions (i.e. GPU vectors can override them +! so that special versions (i.e. GPU vectors can override them) ! ! Arguments: ! swap_status - integer Swap status selector. @@ -84,7 +84,8 @@ submodule (psi_d_comm_v_mod) psi_d_swapdata_impl use psb_base_mod use psb_error_mod, only: psb_get_debug_level, psb_get_debug_unit, psb_debug_ext_ 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_ + & psb_comm_persistent_ineighbor_alltoallv_, psb_comm_rma_pull_, psb_comm_rma_push_, & + & psb_comm_handle_type use psb_comm_rma_mod, only: psb_comm_rma_handle use psb_comm_factory_mod @@ -99,24 +100,24 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: swap_status - class(psb_d_base_vect_type), intent(inout) :: y - real(psb_dpk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ - class(psb_i_base_vect_type), pointer :: comm_indexes + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes ! communication scheme/status selectors - logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent ! error handling variables - integer(psb_ipk_) :: err_act - character(len=30) :: name + integer(psb_ipk_) :: err_act + character(len=30) :: name info = psb_success_ name = 'psi_dswapdata_vect' @@ -508,26 +509,25 @@ contains include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: swap_status - real(psb_dpk_), intent(in) :: beta + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta class(psb_d_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - class(psb_comm_handle_type), intent(inout) :: comm_handle - integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, my_rank - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical :: debug - character(len=30) :: name - - + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ name = 'psi_dswap_neighbor_topology_vect' @@ -584,20 +584,32 @@ contains buffer_size = topology_total_send + topology_total_recv if (buffer_size > 0) then - 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 neighbor_comm_handle%comm_request = mpi_request_null - - ! Gather send data into contiguous send buffer (polymorphic for GPU) - if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & neighbor_comm_handle%send_indexes, & - & y%combuf(1:topology_total_send)) + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do else - ! No data to send/recv: ensure request indicates idle state neighbor_comm_handle%comm_request = mpi_request_null end if @@ -608,16 +620,16 @@ 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 - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & neighbor_comm_handle%comm_request, iret) + & 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, & + & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/iret/)) @@ -663,10 +675,29 @@ contains ! Scatter received data to local vector positions (polymorphic for GPU) if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & neighbor_comm_handle%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((1+pnti+psb_n_elem_recv_ < 1) .or. (nerv < 0) .or. & + & (1+pnti+psb_n_elem_recv_+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 + end do else ! nothing to wait/scatter end if @@ -722,8 +753,7 @@ contains logical :: do_start, do_wait logical :: debug character(len=30) :: name - - + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ name = 'psi_dswap_neighbor_persistent_topology_vect' @@ -820,11 +850,26 @@ contains neighbor_comm_handle%comm_request = mpi_request_null if (buffer_size > 0) then - ! Gather send data into contiguous send buffer (polymorphic for GPU) - if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & neighbor_comm_handle%send_indexes, & - & y%combuf(1:topology_total_send)) + ! Gather send data into combuf using baseline-style gth calls + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data (baseline layout),', topology_total_send,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do else neighbor_comm_handle%persistent_in_flight = .false. end if @@ -841,7 +886,7 @@ contains & neighbor_comm_handle%send_counts, & & neighbor_comm_handle%send_displs, & & psb_mpi_r_dpk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer + & y%combuf(1), & ! recv buffer (baseline layout) & neighbor_comm_handle%recv_counts, & & neighbor_comm_handle%recv_displs, & & psb_mpi_r_dpk_, & @@ -906,12 +951,18 @@ contains end if neighbor_comm_handle%persistent_in_flight = .false. - ! Scatter received data to local vector positions (polymorphic for GPU) - if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & neighbor_comm_handle%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + ! Scatter received data to local vector positions (baseline-style sct) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data (baseline layout),', topology_total_recv,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + rcv_pt = 1+pnti+psb_n_elem_recv_ + if (nerv > 0) then + call y%sct(rcv_pt,nerv,comm_indexes,beta) + end if + pnti = pnti + nerv + nesd + 3 + end do end if call y%device_wait() @@ -955,6 +1006,8 @@ contains logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed type(psb_comm_rma_handle), pointer :: rma_handle character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n + info = psb_success_ name = 'psi_dswap_rma_pull_vect' @@ -1020,12 +1073,14 @@ contains if (buffer_size > 0) then if (.not. allocated(y%combuf)) then - call y%new_buffer(buffer_size, info) + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= psb_success_) 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) < size(comm_indexes%v)) then ! Need a larger exposed memory area: recreate the RMA window first, ! then reallocate combuf and lazily create a new window below. if (rma_handle%window_open) then @@ -1047,7 +1102,9 @@ contains rma_handle%window_ready = .false. rma_handle%win = mpi_win_null end if - call y%new_buffer(buffer_size, info) + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1075,15 +1132,7 @@ contains end if call y%device_wait() - call mpi_win_lock_all(0, rma_handle%win, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - rma_handle%window_open = .true. - - ! Pull data from each peer. The metadata exchange stays local and simple. + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). do neighbor_idx=1, num_neighbors proc_to_comm = rma_handle%peer_proc(neighbor_idx) recv_count = rma_handle%peer_recv_counts(neighbor_idx) @@ -1106,6 +1155,12 @@ contains end if if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count, psb_mpi_r_dpk_, & & rma_handle%win, iret) @@ -1114,12 +1169,12 @@ contains call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if - end if - call mpi_win_flush(prc_rank, rma_handle%win, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then @@ -1133,18 +1188,8 @@ contains end if end if - ! WAIT phase: close the epoch and scatter the received slice back into Y. + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. if (do_wait) then - if (rma_handle%window_open) then - call mpi_win_unlock_all(rma_handle%win, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - rma_handle%window_open = .false. - end if - if (total_recv > 0) then call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) end if @@ -1184,6 +1229,7 @@ contains integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed type(psb_comm_rma_handle), pointer :: rma_handle character(len=30) :: name @@ -1252,12 +1298,14 @@ contains if (buffer_size > 0) then if (.not. allocated(y%combuf)) then - call y%new_buffer(buffer_size, info) + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= psb_success_) 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) < size(comm_indexes%v)) then ! Need a larger exposed memory area: recreate the RMA window first, ! then reallocate combuf and lazily create a new window below. if (rma_handle%window_open) then @@ -1279,7 +1327,9 @@ contains rma_handle%window_ready = .false. rma_handle%win = mpi_win_null end if - call y%new_buffer(buffer_size, info) + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -1307,6 +1357,25 @@ contains end if call y%device_wait() + ! Pre-post notification receives before opening the window (prevents isend/irecv ordering issues). + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + call mpi_win_lock_all(0, rma_handle%win, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1315,7 +1384,7 @@ contains end if rma_handle%window_open = .true. - ! Push data to each peer. Only the base displacement and count are exchanged. + ! Push data to each peer; after flush send a P2P notification so target knows data arrived. do neighbor_idx=1, num_neighbors proc_to_comm = rma_handle%peer_proc(neighbor_idx) recv_count = rma_handle%peer_recv_counts(neighbor_idx) @@ -1353,6 +1422,13 @@ contains call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then info = psb_err_internal_error_ @@ -1365,7 +1441,7 @@ contains end if end if - ! WAIT phase: close the epoch and apply the receive-side scatter. + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. if (do_wait) then if (rma_handle%window_open) then call mpi_win_unlock_all(rma_handle%win, iret) @@ -1377,11 +1453,19 @@ contains rma_handle%window_open = .false. end if - call mpi_barrier(icomm, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 if (total_recv > 0) then @@ -1417,22 +1501,23 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: swap_status class(psb_d_base_multivect_type), intent(inout) :: y - real(psb_dpk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + real(psb_dpk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! communication scheme/status selectors - logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act - class(psb_i_base_vect_type), pointer :: comm_indexes - character(len=30) :: name + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act + integer(psb_mpk_) :: n, total_send_, total_recv_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name info = psb_success_ @@ -1487,6 +1572,10 @@ contains goto 9999 end if + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + baseline = .false. ineighbor_a2av = .false. ineighbor_a2av_persistent = .false. @@ -1495,10 +1584,20 @@ contains ineighbor_a2av = .true. case(psb_comm_persistent_ineighbor_alltoallv_) ineighbor_a2av_persistent = .true. - case(psb_comm_rma_pull_, psb_comm_rma_push_) - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='RMA swap is not yet enabled for multivectors') - goto 9999 + case(psb_comm_rma_pull_) + call psi_dswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_dswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if case default baseline = .true. end select @@ -1611,7 +1710,7 @@ subroutine psi_dswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes, & end if end if if (debug) write(*,*) my_rank,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) + call y%new_buffer(total_send_+total_recv_,info) call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -1815,10 +1914,12 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in ! locals integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: np, my_rank, n integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + integer(psb_mpk_) :: total_send_, total_recv_ logical :: do_start, do_wait logical, parameter :: debug = .false. character(len=30) :: name @@ -1835,6 +1936,7 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in endif icomm = ctxt%get_mpic() + n = y%get_ncols() neighbor_comm_handle => null() select type(ch => comm_handle) @@ -1867,11 +1969,15 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in end if topology_total_send = neighbor_comm_handle%total_send topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n ! Buffer layout: ! combuf(1 : total_send) = send area ! combuf(total_send+1 : total_send+total_recv) = recv area - buffer_size = topology_total_send + topology_total_recv + buffer_size = total_send_ + total_recv_ if (buffer_size > 0) then call y%new_buffer(buffer_size, info) @@ -1887,7 +1993,7 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' call y%gth(int(topology_total_send,psb_mpk_), & & neighbor_comm_handle%send_indexes, & - & y%combuf(1:topology_total_send)) + & y%combuf(1:total_send_)) end if ! Wait for device (important for GPU subclasses) @@ -1901,9 +2007,9 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in & neighbor_comm_handle%send_counts, & & neighbor_comm_handle%send_displs, & & psb_mpi_r_dpk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & & psb_mpi_r_dpk_, & & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) @@ -1952,7 +2058,7 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_in if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' call y%sct(int(topology_total_recv,psb_mpk_), & & neighbor_comm_handle%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & + & y%combuf(total_send_+1:total_send_+total_recv_), & & beta) end if @@ -2001,10 +2107,11 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet ! locals integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: np, my_rank, n integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ logical :: do_start, do_wait logical, parameter :: debug = .false. character(len=30) :: name @@ -2021,6 +2128,7 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet endif icomm = ctxt%get_mpic() + n = y%get_ncols() neighbor_comm_handle => null() select type(ch => comm_handle) @@ -2062,7 +2170,7 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet ! Buffer layout: ! combuf(1 : total_send) = send area ! combuf(total_send+1 : total_send+total_recv) = recv area - buffer_size = topology_total_send + topology_total_recv + buffer_size = total_send_ + total_recv_ if (buffer_size > 0) then if (.not. allocated(y%combuf)) then @@ -2104,7 +2212,7 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' call y%gth(int(topology_total_send,psb_mpk_), & & neighbor_comm_handle%send_indexes, & - & y%combuf(1:topology_total_send)) + & y%combuf(1:total_send_)) else neighbor_comm_handle%persistent_in_flight = .false. end if @@ -2117,12 +2225,12 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet 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, & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & & psb_mpi_r_dpk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & & psb_mpi_r_dpk_, & & neighbor_comm_handle%graph_comm, & & mpi_info_null, & @@ -2183,7 +2291,7 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' call y%sct(int(topology_total_recv,psb_mpk_), & & neighbor_comm_handle%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & + & y%combuf(total_send_+1:total_send_+total_recv_), & & beta) else neighbor_comm_handle%persistent_in_flight = .false. @@ -2203,5 +2311,436 @@ subroutine psi_dswap_neighbor_topology_multivect_persistent(ctxt,swap_status,bet end subroutine psi_dswap_neighbor_topology_multivect_persistent + subroutine psi_dswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_dswap_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dswap_rma_pull_multivect + + + subroutine psi_dswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_dswap_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dswap_rma_push_multivect + + end submodule psi_d_swapdata_impl diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index 135e5f493..f16a944fa 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -104,23 +104,20 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: swap_status - real(psb_dpk_), intent(in) :: beta - class(psb_d_base_vect_type), intent(inout) :: y - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_vect_type), intent(inout) :: y + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ - class(psb_i_base_vect_type), pointer :: comm_indexes + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes character(len=20) :: name - ! local variables used to detect the communication scheme - logical :: baseline, neighbor_a2av - info = psb_success_ name = 'psi_dswaptran_vect' call psb_erractionsave(err_act) @@ -174,33 +171,42 @@ contains goto 9999 end if - baseline = .false. - neighbor_a2av = .false. select case(y%comm_handle%comm_type) - case(psb_comm_ineighbor_alltoallv_, psb_comm_persistent_ineighbor_alltoallv_) - neighbor_a2av = .true. - case default - baseline = .true. - end select - - if (baseline) then - call psi_dtran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + case(psb_comm_ineighbor_alltoallv_) + call psi_dtran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') goto 9999 end if - else if (neighbor_a2av) then - call psi_dtran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_dtran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& & num_neighbors,total_send,total_recv,y%comm_handle,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') goto 9999 end if - else - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible swap_status settings: neither baseline nor neighbor_a2av is true') - goto 9999 - end if + case(psb_comm_rma_pull_) + call psi_dtran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_dtran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_dtran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -687,8 +693,6 @@ contains class(psb_i_base_vect_type), pointer :: comm_indexes character(len=20) :: name - ! local variables used to detect the communication scheme - logical :: baseline, neighbor_a2av integer(psb_ipk_) :: setflag @@ -754,33 +758,42 @@ contains goto 9999 end if - baseline = .false. - neighbor_a2av = .false. select case(y%comm_handle%comm_type) - case(psb_comm_ineighbor_alltoallv_, psb_comm_persistent_ineighbor_alltoallv_) - neighbor_a2av = .true. - case default - baseline = .true. - end select - - if (baseline) then - call psi_dtran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + case(psb_comm_ineighbor_alltoallv_) + call psi_dtran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_dtran_neighbor_persistent_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') goto 9999 end if - else if (neighbor_a2av) then - call psi_dtran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,& - & total_send,total_recv,y%comm_handle,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + case(psb_comm_rma_pull_) + call psi_dtran_rma_pull_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') goto 9999 end if - else - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible swap_status settings: neither baseline nor neighbor_a2av is true') - goto 9999 - end if + case(psb_comm_rma_push_) + call psi_dtran_rma_push_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_dtran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -1221,4 +1234,1334 @@ contains + subroutine psi_dtran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_dtran_neighbor_persistent_topology_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes (we "send" recv data) + if (debug) write(*,*) my_rank,' tran_persistent_vect: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv counts in alltoallv_init + ! send = recv_indexes data with recv_counts/displs + ! recv = into send_indexes area with send_counts/displs + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(topology_total_recv + 1), & + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_vect: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_neighbor_persistent_topology_vect + + + subroutine psi_dtran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! Effective sizes for transpose: + ! eff_send = total_recv (we expose recv_indexes data) + ! eff_recv = total_send (we GET into the send_indexes area) + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_dtran_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_rma_pull_vect + + + subroutine psi_dtran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_dtran_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push our recv_indexes data to each peer's send_indexes area; notify after flush. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_rma_push_vect + + + subroutine psi_dtran_neighbor_persistent_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret, n + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_dtran_neighbor_persistent_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor multivect swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:total_recv_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv in alltoallv_init + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_recv_ + 1), & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(total_recv_+1:total_recv_+total_send_), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_neighbor_persistent_topology_multivect + + + subroutine psi_dtran_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_dtran_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull multivect') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_rma_pull_multivect + + + subroutine psi_dtran_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_dtran_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push multivect') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_rma_push_multivect + + end submodule psi_d_swaptran_impl diff --git a/base/comm/internals/psi_eovrl_restr_a.f90 b/base/comm/internals/psi_eovrl_restr_a.f90 index 2fe2b7881..960ebb4d1 100644 --- a/base/comm/internals/psi_eovrl_restr_a.f90 +++ b/base/comm/internals/psi_eovrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_eovrl_save_a.f90 b/base/comm/internals/psi_eovrl_save_a.f90 index 41e9e5198..23cae9220 100644 --- a/base/comm/internals/psi_eovrl_save_a.f90 +++ b/base/comm/internals/psi_eovrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_eovrl_upd_a.f90 b/base/comm/internals/psi_eovrl_upd_a.f90 index 0b6e6f9db..d3caaae33 100644 --- a/base/comm/internals/psi_eovrl_upd_a.f90 +++ b/base/comm/internals/psi_eovrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_eswapdata_a.F90 b/base/comm/internals/psi_eswapdata_a.F90 index 5285b4640..122863ae6 100644 --- a/base/comm/internals/psi_eswapdata_a.F90 +++ b/base/comm/internals/psi_eswapdata_a.F90 @@ -39,7 +39,7 @@ ! 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_) +! D integer(psb_epk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -70,10 +70,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:,:) - integer The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do +! 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 @@ -97,13 +97,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -165,12 +166,13 @@ integer(psb_epk_), target :: work(:) #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n 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 + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -348,7 +350,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_epk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -370,7 +372,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag + 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,& @@ -401,7 +403,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -510,7 +512,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf ! 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_) + ! D integer(psb_epk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -541,10 +543,10 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf ! ! ! n - integer Number of columns in Y - ! beta - integer Choose overwrite or sum. - ! y(:) - integer The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - integer Buffer space. If not sufficient, will do + ! 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 @@ -565,12 +567,13 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -648,7 +651,8 @@ 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_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -830,7 +834,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & psb_mpi_epk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -852,7 +856,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag + p2ptag = psb_double_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -882,7 +886,7 @@ integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_eswaptran_a.F90 b/base/comm/internals/psi_eswaptran_a.F90 index c095f7084..0c3f0c248 100644 --- a/base/comm/internals/psi_eswaptran_a.F90 +++ b/base/comm/internals/psi_eswaptran_a.F90 @@ -43,7 +43,7 @@ ! 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_) +! D integer(psb_epk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -74,10 +74,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:,:) - integer The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do +! 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 @@ -101,13 +101,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -149,7 +150,7 @@ contains goto 9999 end if - call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + 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) @@ -174,7 +175,8 @@ contains 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_), intent(inout) :: y(:,:) + integer(psb_epk_), intent(in) :: beta integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -360,7 +362,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & psb_mpi_epk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -383,7 +385,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_epk_,prcid(i),& @@ -413,7 +415,7 @@ contains nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -525,7 +527,7 @@ contains ! 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_) + ! D integer(psb_epk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -556,10 +558,10 @@ contains ! ! ! n - integer Number of columns in Y - ! beta - integer Choose overwrite or sum. - ! y(:) - integer The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - integer Buffer space. If not sufficient, will do + ! 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 @@ -579,12 +581,13 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -659,7 +662,8 @@ contains 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_), intent(inout) :: y(:) + integer(psb_epk_), intent(in) :: beta integer(psb_epk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -845,7 +849,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & psb_mpi_epk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -868,7 +872,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & psb_mpi_epk_,prcid(i),& @@ -896,7 +900,7 @@ contains 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_i2ovrl_restr_a.f90 b/base/comm/internals/psi_i2ovrl_restr_a.f90 index 49cf864d1..8272e68b9 100644 --- a/base/comm/internals/psi_i2ovrl_restr_a.f90 +++ b/base/comm/internals/psi_i2ovrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_i2ovrl_save_a.f90 b/base/comm/internals/psi_i2ovrl_save_a.f90 index 09c0cd19e..ca81d36d0 100644 --- a/base/comm/internals/psi_i2ovrl_save_a.f90 +++ b/base/comm/internals/psi_i2ovrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_i2ovrl_upd_a.f90 b/base/comm/internals/psi_i2ovrl_upd_a.f90 index 82d52fdf5..2d9f57b85 100644 --- a/base/comm/internals/psi_i2ovrl_upd_a.f90 +++ b/base/comm/internals/psi_i2ovrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_i2swapdata_a.F90 b/base/comm/internals/psi_i2swapdata_a.F90 index cb368d540..e8713aa3f 100644 --- a/base/comm/internals/psi_i2swapdata_a.F90 +++ b/base/comm/internals/psi_i2swapdata_a.F90 @@ -39,7 +39,7 @@ ! 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_) +! D integer(psb_i2pk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -70,10 +70,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:,:) - integer The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do +! 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 @@ -97,13 +97,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -165,12 +166,13 @@ integer(psb_i2pk_), target :: work(:) #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n 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 + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -348,7 +350,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_i2pk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -370,7 +372,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag + 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,& @@ -401,7 +403,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -510,7 +512,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf ! 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_) + ! D integer(psb_i2pk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -541,10 +543,10 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf ! ! ! n - integer Number of columns in Y - ! beta - integer Choose overwrite or sum. - ! y(:) - integer The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - integer Buffer space. If not sufficient, will do + ! 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 @@ -565,12 +567,13 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -648,7 +651,8 @@ 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_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -830,7 +834,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & psb_mpi_i2pk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -852,7 +856,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag + p2ptag = psb_double_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -882,7 +886,7 @@ integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_i2swaptran_a.F90 b/base/comm/internals/psi_i2swaptran_a.F90 index 3244dd66b..f04e7a2b4 100644 --- a/base/comm/internals/psi_i2swaptran_a.F90 +++ b/base/comm/internals/psi_i2swaptran_a.F90 @@ -30,7 +30,7 @@ ! ! ! -! File: psi_i2swaptran.F90 +! File: psi_i2swaptran_a.F90 ! ! Subroutine: psi_i2swaptranm ! Implements the data exchange among processes. This is similar to Xswapdata, but @@ -43,7 +43,7 @@ ! 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_) +! D integer(psb_i2pk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -74,10 +74,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:,:) - integer The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do +! 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 @@ -101,13 +101,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -149,7 +150,7 @@ contains goto 9999 end if - call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + 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) @@ -174,7 +175,8 @@ contains 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_), intent(inout) :: y(:,:) + integer(psb_i2pk_), intent(in) :: beta integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -360,7 +362,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & psb_mpi_i2pk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -383,7 +385,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_i2pk_,prcid(i),& @@ -413,7 +415,7 @@ contains nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -525,7 +527,7 @@ contains ! 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_) + ! D integer(psb_i2pk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -556,10 +558,10 @@ contains ! ! ! n - integer Number of columns in Y - ! beta - integer Choose overwrite or sum. - ! y(:) - integer The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - integer Buffer space. If not sufficient, will do + ! 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 @@ -579,12 +581,13 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -659,7 +662,8 @@ contains 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_), intent(inout) :: y(:) + integer(psb_i2pk_), intent(in) :: beta integer(psb_i2pk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -845,7 +849,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & psb_mpi_i2pk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -868,7 +872,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & psb_mpi_i2pk_,prcid(i),& @@ -896,7 +900,7 @@ contains 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_iovrl_restr.f90 b/base/comm/internals/psi_iovrl_restr.f90 index 838b7e50b..21d8b23bf 100644 --- a/base/comm/internals/psi_iovrl_restr.f90 +++ b/base/comm/internals/psi_iovrl_restr.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_iovrl_save.f90 b/base/comm/internals/psi_iovrl_save.f90 index ed84f7b1b..21eae3510 100644 --- a/base/comm/internals/psi_iovrl_save.f90 +++ b/base/comm/internals/psi_iovrl_save.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_iovrl_upd.f90 b/base/comm/internals/psi_iovrl_upd.f90 index 6873e3d34..d77747b73 100644 --- a/base/comm/internals/psi_iovrl_upd.f90 +++ b/base/comm/internals/psi_iovrl_upd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index 4d749ce62..43cd54c40 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -41,7 +41,7 @@ ! 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_) +! D integer(psb_ipk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -53,30 +53,22 @@ ! is scattered in the owned indices, and BETA=1. ! The first routine picks the desired exchange index list and passes it to the second. ! This version works on encapsulated vectors, and uses their methods to do GTH and SCT, -! so that special versions (i.e. GPU vectors can override them +! so that special versions (i.e. GPU vectors can override them) ! ! 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) +! swap_status - integer Swap status selector. +! It is interpreted as a communication status: +! psb_comm_status_start_ -> START phase +! psb_comm_status_wait_ -> WAIT phase +! psb_comm_status_unknown_ -> START+WAIT +! The communication scheme is selected from +! y%comm_handle%comm_type. ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. +! beta - real Choose overwrite or sum. ! y - type(psb_@x@_vect_type) The data area -! desc_a - type(psb_desc_type). The communication descriptor. +! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -88,10 +80,18 @@ ! ! submodule (psi_i_comm_v_mod) psi_i_swapdata_impl + use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_ use psb_base_mod + use psb_error_mod, only: psb_get_debug_level, psb_get_debug_unit, psb_debug_ext_ + 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_, & + & psb_comm_handle_type + use psb_comm_rma_mod, only: psb_comm_rma_handle + use psb_comm_factory_mod + contains - subroutine psi_iswapdata_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_iswapdata_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -100,31 +100,32 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: swap_status + class(psb_i_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent - ! 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 + character(len=30) :: name info = psb_success_ name = 'psi_iswapdata_vect' call psb_erractionsave(err_act) ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) + + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -132,7 +133,7 @@ contains endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -145,124 +146,166 @@ contains call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - 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') + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_iswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + + 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) 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_iswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + case(psb_comm_ineighbor_alltoallv_) + call psi_iswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + call psb_errpush(info,name,a_err='neighbor nonblocking swap') goto 9999 end if - else + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_iswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_iswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_iswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') goto 9999 - end if + end select call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return end subroutine psi_iswapdata_vect - subroutine psi_iswap_baseline_vect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) - + subroutine psi_iswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! 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_) :: icomm + integer(psb_mpk_) :: np, my_rank + 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 + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti, n + logical :: do_send,do_recv + logical, parameter :: usersend=.false. + logical :: debug + character(len=20) :: name info = psb_success_ - name = 'psi_iswap_vidx_vect' + name = 'psi_iswap_baseline_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = total_recv * n - totsnd_ = total_send * n + do_send = (swap_status == psb_comm_status_start_).or.(swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_).or.(swap_status == psb_comm_status_sync_) + + total_recv_ = total_recv * n + total_send_ = total_send * n call comm_indexes%sync() - if (debug) write(*,*) me,'Internal buffer' + if (debug) write(*,*) my_rank,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) + call psb_errpush(info,name,a_err='Unfinished communication? Something is wrong....') goto 9999 end if end if - if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -273,16 +316,16 @@ contains 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 + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' Gather ' + if (debug) write(*,*) my_rank,' Gather ' ! ! Then gather for sending. ! @@ -293,6 +336,16 @@ contains snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ idx_pt = snd_pt + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if call y%gth(idx_pt,nesd,comm_indexes) pnti = pnti + nerv + nesd + 3 end do @@ -302,7 +355,7 @@ contains ! call y%device_wait() - if (debug) write(*,*) me,' isend' + if (debug) write(*,*) my_rank,' isend' ! ! Then send ! @@ -310,7 +363,7 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) nerv = comm_indexes%v(pnti+psb_n_elem_recv_) @@ -318,10 +371,10 @@ contains 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 + if ((nesd>0).and.(proc_to_comm /= my_rank)) then call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -335,8 +388,8 @@ contains end if if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -346,9 +399,9 @@ contains end if call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' pnti = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) nerv = comm_indexes%v(pnti+psb_n_elem_recv_) @@ -356,9 +409,9 @@ contains snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - if (proc_to_comm /= me)then + if (proc_to_comm /= my_rank)then if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -366,25 +419,25 @@ contains end if end if if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%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 + else if (proc_to_comm == my_rank) then if (nesd /= nerv) then write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd + & '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 - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' scatter' + if (debug) write(*,*) my_rank,' scatter' pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -396,29 +449,43 @@ contains 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) + if ((idx_pt < 1) .or. (nerv < 0) .or. (idx_pt+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + + if (debug) write(*,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) call y%sct(rcv_pt,nerv,comm_indexes,beta) - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do + ! ! Waited for everybody, clean up ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device ! - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' + if (debug) write(*,*) my_rank,' free buffer' call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) + if (info == 0) then + if (allocated(y%comm_handle)) call y%comm_handle%free(info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if - if (debug) write(*,*) me,' done' + if (debug) write(*,*) my_rank,' done' end if @@ -432,7 +499,8 @@ contains - subroutine psi_iswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + subroutine psi_iswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -441,28 +509,30 @@ contains include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name - + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ name = 'psi_iswap_neighbor_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -471,8 +541,24 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() @@ -480,59 +566,77 @@ contains ! START phase: build topology (if needed), gather, post MPI ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - ! Lazy initialization: build the topology on first call - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if - - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv ! Buffer layout: ! combuf(1 : total_send) = send area ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if (buffer_size > 0) then + 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 + neighbor_comm_handle%comm_request = mpi_request_null + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%comm_request = mpi_request_null end if - y%communication_handle = mpi_request_null - - ! Gather send data into contiguous send buffer (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) ! Wait for device (important for GPU subclasses) call y%device_wait() ! Post non-blocking neighborhood alltoallv - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & + 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 - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & & psb_mpi_r_dpk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_r_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null end if end if ! do_start @@ -542,42 +646,72 @@ contains ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then - ! No matching start? Something is wrong - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%comm_request = mpi_request_null + else + if (neighbor_comm_handle%comm_request == mpi_request_null) then + write(psb_err_unit,*) my_rank, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', & + & neighbor_comm_handle%is_initialized + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if - ! Wait for the non-blocking collective to complete - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((1+pnti+psb_n_elem_recv_ < 1) .or. (nerv < 0) .or. & + & (1+pnti+psb_n_elem_recv_+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 + end do + else + ! nothing to wait/scatter end if - ! Scatter received data to local vector positions (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) - ! Clean up - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_vect: done' + if (debug) write(*,*) my_rank,' nbr_vect: done' end if ! do_wait @@ -591,102 +725,250 @@ contains - - - - - - module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,info,data) + subroutine psi_iswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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 - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta - class(psb_i_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - type(psb_ctxt_type) :: ctxt - 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 - - ! 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 + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_iswapdata_multivect' + name = 'psi_iswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info = psb_err_context_error_ + 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 + icomm = ctxt%get_mpic() - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swap') + goto 9999 + end select - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') goto 9999 end if - 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 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - 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 + call comm_indexes%sync() - if (baseline) then - call psi_iswap_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') + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') goto 9999 end if - else if (neighbor_a2av) then - call psi_iswap_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 + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if 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 + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into combuf using baseline-style gth calls + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data (baseline layout),', topology_total_send,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Lazy persistent-init: build the request once, then reuse with START/WAIT. + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (baseline-style sct) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data (baseline layout),', topology_total_recv,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + rcv_pt = 1+pnti+psb_n_elem_recv_ + if (nerv > 0) then + call y%sct(rcv_pt,nerv,comm_indexes,beta) + end if + pnti = pnti + nerv + nesd + 3 + end do + end if + + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -694,12 +976,10 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_iswapdata_multivect - + end subroutine psi_iswap_neighbor_persistent_topology_vect - subroutine psi_iswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_iswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -708,244 +988,1105 @@ contains include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta - class(psb_i_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv - integer(psb_ipk_), intent(out) :: info + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n - ! 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_iswap_baseline_multivect' + name = 'psi_iswap_rma_pull_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 - endif + end if 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 + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select - totrcv_ = total_recv * n - totsnd_ = total_send * n + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%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 + ! START phase: build the layout once, prepare the exposed buffer, then issue RMA. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 end if end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null - call psb_realloc(num_neighbors,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%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) + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + 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 - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,comm_indexes) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Expose combuf once and keep the window around until the descriptor changes. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if ((recv_pos < 1) .or. (recv_count < 0) .or. (recv_pos+max(0,recv_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull local receive bounds error') + goto 9999 + end if + + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_ipk_, prc_rank, remote_disp, recv_count, psb_mpi_ipk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if - ! - ! Then wait for device - ! call y%device_wait() + end if - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! + call psb_erractionrestore(err_act) + return - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_iswap_rma_pull_vect + + + subroutine psi_iswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,info) +#ifdef PSB_MPI_MOD + use mpi +#endif + implicit none +#ifdef PSB_MPI_H + include 'mpif.h' +#endif - 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) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_iswap_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! START phase: identical layout handling, but the remote metadata describes the receive side. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') 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(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%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_ + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_open = .false. 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_ + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null 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 + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(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 + end if - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Keep the window alive across repetitions: it is created once and reused. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if - 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,comm_indexes,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 + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window (prevents isend/irecv ordering issues). + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push data to each peer; after flush send a P2P notification so target knows data arrived. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if ((send_pos < 1) .or. (send_count < 0) .or. (send_pos+max(0,send_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push local send bounds error') + goto 9999 + end if + + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_ipk_, prc_rank, remote_disp, send_count, psb_mpi_ipk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if + + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_iswap_rma_push_vect + + + + ! + ! + ! Subroutine: psi_iswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_iswapdata_multivect(swap_status,beta,y,desc_a,info,data) +#ifdef PSB_MPI_MOD + use mpi +#endif + implicit none +#ifdef PSB_MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: swap_status + class(psb_i_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act + integer(psb_mpk_) :: n, total_send_, total_recv_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name + + + info = psb_success_ + name = 'psi_iswapdata_multivect' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,my_rank,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_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + if ((swap_status /= psb_comm_status_start_) .and. (swap_status /= psb_comm_status_wait_) & + & .and. (swap_status /= psb_comm_status_unknown_)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if + + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') + goto 9999 + end if + + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + baseline = .false. + ineighbor_a2av = .false. + ineighbor_a2av_persistent = .false. + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + ineighbor_a2av = .true. + case(psb_comm_persistent_ineighbor_alltoallv_) + ineighbor_a2av_persistent = .true. + case(psb_comm_rma_pull_) + call psi_iswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_iswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default + baseline = .true. + end select + + if (baseline) then + call psi_iswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + else if (ineighbor_a2av) then + call psi_iswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') + goto 9999 + end if + else if (ineighbor_a2av_persistent) then + call psi_iswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_iswapdata_multivect + + + + +subroutine psi_iswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti + logical :: do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info = psb_success_ + name = 'psi_iswap_baseline_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swap') + goto 9999 + end select + + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + total_recv_ = total_recv * n + total_send_ = total_send * n + + call comm_indexes%sync() + + if (debug) write(*,*) my_rank,'Internal buffer' + if (do_send) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) my_rank,'do_send start' + call y%new_buffer(total_send_+total_recv_,info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + baseline_comm_handle%comid = mpi_request_null + call psb_realloc(num_neighbors,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'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,baseline_comm_handle%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(*,*) my_rank,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,comm_indexes) + 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(*,*) my_rank,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= my_rank)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%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 (do_recv) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%comid)) then + ! + ! No matching send? Something is wrong.... ! - y%comid = mpi_request_null + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(num_neighbors,prcid,info) + + if (debug) write(*,*) my_rank,' wait' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= my_rank)then + if (nesd>0) then + call mpi_wait(baseline_comm_handle%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 + if (nerv>0) then + call mpi_wait(baseline_comm_handle%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 == my_rank) 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 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) my_rank,' scatter' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,comm_indexes,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 + ! + baseline_comm_handle%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) my_rank,' wait' + call y%device_wait() + if (debug) write(*,*) my_rank,' free buffer' + call y%free_buffer(info) + if (info == 0) then + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_iswap_baseline_multivect + + + +subroutine psi_iswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_iswap_neighbor_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (buffer_size > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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 + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + if ((topology_total_send + topology_total_recv) > 0) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if - ! - ! 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) + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Wait for the non-blocking collective to complete + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + 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,' done' end if + ! Scatter received data to local vector positions (polymorphic for GPU) + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + end if - call psb_erractionrestore(err_act) - return -9999 call psb_error_handler(ctxt,err_act) + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' - return - end subroutine psi_iswap_baseline_multivect + end if ! do_wait + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return +end subroutine psi_iswap_neighbor_topology_multivect -subroutine psi_iswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) +subroutine psi_iswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -955,36 +2096,52 @@ subroutine psi_iswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,n #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_multivect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: np, my_rank, n integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ logical :: do_start, do_wait logical, parameter :: debug = .false. character(len=30) :: name info = psb_success_ - name = 'psi_iswap_neighbor_topology_multivect' + name = 'psi_iswap_neighbor_topology_multivect_persistent' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + icomm = ctxt%get_mpic() + n = y%get_ncols() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) call comm_indexes%sync() @@ -992,60 +2149,115 @@ subroutine psi_iswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,n ! START phase: build topology (if needed), gather, post MPI ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - ! Lazy initialization: build the topology on first call - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, & + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & & ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if - - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv ! Buffer layout: ! combuf(1 : total_send) = send area ! combuf(total_send+1 : total_send+total_recv) = recv area - buffer_size = topology_total_send + topology_total_recv + buffer_size = total_send_ + total_recv_ - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - ! Gather send data into contiguous send buffer (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + if (buffer_size > 0) then + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if ! Wait for device (important for GPU subclasses) call y%device_wait() - ! Post non-blocking neighborhood alltoallv - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_r_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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 + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. end if end if ! do_start @@ -1055,42 +2267,38 @@ subroutine psi_iswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,n ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then - ! No matching start? Something is wrong - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 - end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + if ((topology_total_send + topology_total_recv) > 0) then + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if - ! Wait for the non-blocking collective to complete - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 - end if + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. - ! Scatter received data to local vector positions (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & & beta) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if - - ! Clean up - y%communication_handle = mpi_request_null call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 - end if - if (debug) write(*,*) me,' nbr_vect: done' + if (debug) write(*,*) my_rank,' nbr_vect: done' end if ! do_wait @@ -1100,10 +2308,438 @@ subroutine psi_iswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,n 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_iswap_neighbor_topology_multivect +end subroutine psi_iswap_neighbor_topology_multivect_persistent + + + subroutine psi_iswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_iswap_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_ipk_, prc_rank, remote_disp, recv_count*n, psb_mpi_ipk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_iswap_rma_pull_multivect + + + subroutine psi_iswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_iswap_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_ipk_, prc_rank, remote_disp, send_count*n, psb_mpi_ipk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_iswap_rma_push_multivect end submodule psi_i_swapdata_impl diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index 2e540bb39..4b7f7ffb7 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -43,7 +43,7 @@ ! 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_) +! D integer(psb_ipk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -59,12 +59,12 @@ ! ! ! Arguments: -! flag - integer Choose the algorithm for data exchange: +! swap_status - 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 +! swap_mpi = iand(swap_status,psb_swap_mpi_) /= 0 +! swap_sync = iand(swap_status,psb_swap_sync_) /= 0 +! swap_send = iand(swap_status,psb_swap_send_) /= 0 +! swap_recv = iand(swap_status,psb_swap_recv_) /= 0 ! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_sync): use PSB_SND and PSB_RCV in ! synchronized pairs @@ -77,9 +77,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y - type(psb_i_vect_type) The data area +! beta - real Choose overwrite or sum. +! y - type(psb_d_vect_type) The data area ! desc_a - type(psb_desc_type). The communication descriptor. +! our own internal allocation. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -89,10 +90,11 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -submodule (psi_i_comm_v_mod) psi_i_swaptran_impl +submodule (psi_i_comm_v_mod) psi_i_swaptran_impl use psb_base_mod + use psb_comm_factory_mod contains - module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_iswaptran_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -102,21 +104,19 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: y - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ - class(psb_i_base_vect_type), pointer :: comm_indexes - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av - character(len=20) :: name + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=20) :: name info = psb_success_ name = 'psi_iswaptran_vect' @@ -143,34 +143,71 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if - ! choose baseline or neighbor-topology algorithm - 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 - - if (baseline) then - call psi_itran_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else if (neighbor_a2av) then - call psi_itran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else - call psb_errpush(psb_err_mpi_error_,name,a_err='Incompatible flag settings') + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if + + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_itran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_itran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_itran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_itran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_itran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select + call psb_erractionrestore(err_act) return @@ -181,7 +218,7 @@ contains ! ! - ! Subroutine: psi_itran_vidx_vect + ! Subroutine: psi_itran_baseline_vect ! Data exchange among processes. ! ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods @@ -192,8 +229,8 @@ contains ! ! ! - subroutine psi_itran_baseline_vect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + module subroutine psi_itran_baseline_vect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -204,11 +241,12 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals @@ -216,7 +254,8 @@ contains 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_,& + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -228,29 +267,35 @@ contains call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then - info = psb_err_context_error_ + info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - totrcv_ = total_recv * n - totsnd_ = total_send * n + total_recv_ = total_recv * n + total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -260,17 +305,17 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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_ @@ -279,7 +324,7 @@ contains 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do @@ -291,13 +336,13 @@ contains pnti = 1 snd_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + call y%gth(idx_pt,nerv,idx) pnti = pnti + nerv + nesd + 3 end do @@ -315,18 +360,18 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -341,7 +386,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -353,17 +398,17 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -371,7 +416,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -394,22 +439,22 @@ contains snd_pt = 1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -418,7 +463,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -437,27 +484,32 @@ contains end subroutine psi_itran_baseline_vect - subroutine psi_itran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + + + subroutine psi_itran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. @@ -467,7 +519,7 @@ contains info = psb_success_ name = 'psi_itran_neighbor_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -476,25 +528,43 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, & + & a_err='neighbor_topology_init') goto 9999 end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -502,70 +572,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran: gathering send data,', topology_total_send,' elems' - ! For tran we gather from recv_indexes (swap of roles) - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() - - if (debug) write(*,*) me,' nbr_tran: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_r_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_ipk_, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_ipk_, & + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran: scattering recv data,', topology_total_recv,' elems' - ! For tran we scatter into send_indexes (swap of roles) - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran: done' - end if + if (debug) write(*,*) me,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -577,7 +658,18 @@ contains - module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,info,data) + + ! + ! + ! + ! + ! Subroutine: psi_iswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_iswaptran_multivect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -587,13 +679,12 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_multivect_type), intent(inout) :: y type(psb_desc_type),target :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional :: data - ! locals type(psb_ctxt_type) :: ctxt @@ -602,9 +693,8 @@ contains class(psb_i_base_vect_type), pointer :: comm_indexes character(len=20) :: name - ! local variables for communication - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av + integer(psb_ipk_) :: setflag + info = psb_success_ name = 'psi_iswaptran_multivect' @@ -614,7 +704,7 @@ contains icomm = ctxt%get_mpic() call psb_info(ctxt,me,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif @@ -631,33 +721,80 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if - 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 - - if (baseline) then - call psi_itran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else if (neighbor_a2av) then - call psi_itran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else - call psb_errpush(psb_err_mpi_error_,name,a_err='Incompatible flag settings') + setflag = swap_status + if (swap_status == psb_swap_start_) then + setflag = psb_comm_status_start_ + else if (swap_status == psb_swap_wait_) then + setflag = psb_comm_status_wait_ + else if ((iand(swap_status, psb_swap_send_) /= 0) .or. (iand(swap_status, psb_swap_recv_) /= 0) .or. & + & (iand(swap_status, psb_swap_mpi_) /= 0) .or. (iand(swap_status, psb_swap_sync_) /= 0)) then + setflag = psb_comm_status_sync_ + end if + + if ((setflag /= psb_comm_status_start_) .and. (setflag /= psb_comm_status_wait_) .and. & + & (setflag /= psb_comm_status_sync_)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status') + goto 9999 + end if + + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + call y%comm_handle%set_swap_status(setflag, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_itran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_itran_neighbor_persistent_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_itran_rma_pull_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_itran_rma_push_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_itran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select + call psb_erractionrestore(err_act) return @@ -666,9 +803,8 @@ contains return end subroutine psi_iswaptran_multivect - - module subroutine psi_itran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + subroutine psi_itran_baseline_multivect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -679,19 +815,21 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info + class(psb_comm_handle_type), intent(inout) :: comm_handle ! 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_,& + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -699,34 +837,40 @@ contains character(len=20) :: name info = psb_success_ - name = 'psi_itran_baseline_multivect' + name = 'psi_itran_vidx_multivect' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then - info = psb_err_context_error_ + info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - totrcv_ = total_recv * n - totsnd_ = total_send * n + total_recv_ = total_recv * n + total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -736,25 +880,25 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -766,13 +910,13 @@ contains ! Then gather for sending. ! pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + 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 @@ -789,19 +933,19 @@ contains ! pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -817,7 +961,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -829,16 +973,16 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_int_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -846,7 +990,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -868,17 +1012,17 @@ contains if (debug) write(*,*) me,' scatter' pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 @@ -888,7 +1032,7 @@ contains ! ! Waited for com, cleanup comid ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -897,7 +1041,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -916,36 +1062,40 @@ contains end subroutine psi_itran_baseline_multivect - subroutine psi_itran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + subroutine psi_itran_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_multivect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. character(len=30) :: name + info = psb_success_ name = 'psi_itran_neighbor_topology_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -954,17 +1104,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_mv: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_mv: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -972,9 +1135,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -982,68 +1148,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_mv: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() - - if (debug) write(*,*) me,' nbr_tran_mv: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_r_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_ipk_, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_ipk_, & + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_mv: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_mv: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_mv: done' - end if + if (debug) write(*,*) me,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -1054,4 +1233,1335 @@ contains end subroutine psi_itran_neighbor_topology_multivect + + subroutine psi_itran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_itran_neighbor_persistent_topology_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes (we "send" recv data) + if (debug) write(*,*) my_rank,' tran_persistent_vect: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv counts in alltoallv_init + ! send = recv_indexes data with recv_counts/displs + ! recv = into send_indexes area with send_counts/displs + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_ipk_, & + & y%combuf(topology_total_recv + 1), & + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_ipk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_vect: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_neighbor_persistent_topology_vect + + + subroutine psi_itran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! Effective sizes for transpose: + ! eff_send = total_recv (we expose recv_indexes data) + ! eff_recv = total_send (we GET into the send_indexes area) + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_itran_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_ipk_, prc_rank, remote_disp, recv_count, psb_mpi_ipk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_rma_pull_vect + + + subroutine psi_itran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_itran_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push our recv_indexes data to each peer's send_indexes area; notify after flush. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_ipk_, prc_rank, remote_disp, send_count, psb_mpi_ipk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_rma_push_vect + + + subroutine psi_itran_neighbor_persistent_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret, n + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_itran_neighbor_persistent_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor multivect swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:total_recv_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv in alltoallv_init + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & psb_mpi_ipk_, & + & y%combuf(total_recv_ + 1), & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_ipk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(total_recv_+1:total_recv_+total_send_), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_neighbor_persistent_topology_multivect + + + subroutine psi_itran_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_itran_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull multivect') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_ipk_, prc_rank, remote_disp, recv_count*n, psb_mpi_ipk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_rma_pull_multivect + + + subroutine psi_itran_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_itran_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push multivect') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_ipk_, prc_rank, remote_disp, send_count*n, psb_mpi_ipk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_rma_push_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 ebc7a8d1a..dd2b77dd7 100644 --- a/base/comm/internals/psi_lovrl_restr.f90 +++ b/base/comm/internals/psi_lovrl_restr.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_lovrl_save.f90 b/base/comm/internals/psi_lovrl_save.f90 index 4e3b26a9f..2b5b53779 100644 --- a/base/comm/internals/psi_lovrl_save.f90 +++ b/base/comm/internals/psi_lovrl_save.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_lovrl_upd.f90 b/base/comm/internals/psi_lovrl_upd.f90 index 0d1701e2b..a14f418b6 100644 --- a/base/comm/internals/psi_lovrl_upd.f90 +++ b/base/comm/internals/psi_lovrl_upd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_lswapdata.F90 b/base/comm/internals/psi_lswapdata.F90 index 11327e343..d5b6efed7 100644 --- a/base/comm/internals/psi_lswapdata.F90 +++ b/base/comm/internals/psi_lswapdata.F90 @@ -41,7 +41,7 @@ ! 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_) +! D integer(psb_lpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -53,30 +53,22 @@ ! is scattered in the owned indices, and BETA=1. ! The first routine picks the desired exchange index list and passes it to the second. ! This version works on encapsulated vectors, and uses their methods to do GTH and SCT, -! so that special versions (i.e. GPU vectors can override them +! so that special versions (i.e. GPU vectors can override them) ! ! 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) +! swap_status - integer Swap status selector. +! It is interpreted as a communication status: +! psb_comm_status_start_ -> START phase +! psb_comm_status_wait_ -> WAIT phase +! psb_comm_status_unknown_ -> START+WAIT +! The communication scheme is selected from +! y%comm_handle%comm_type. ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. +! beta - real Choose overwrite or sum. ! y - type(psb_@x@_vect_type) The data area -! desc_a - type(psb_desc_type). The communication descriptor. +! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -87,11 +79,19 @@ ! ! ! -submodule (psi_l_comm_v_mod) psi_l_swapdata_impl +submodule (psi_l_comm_v_mod) psi_l_swapdata_impl + use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_ use psb_base_mod + use psb_error_mod, only: psb_get_debug_level, psb_get_debug_unit, psb_debug_ext_ + 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_, & + & psb_comm_handle_type + use psb_comm_rma_mod, only: psb_comm_rma_handle + use psb_comm_factory_mod + contains - subroutine psi_lswapdata_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_lswapdata_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -100,35 +100,32 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta - class(psb_l_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + class(psb_l_base_vect_type), intent(inout) :: y + integer(psb_lpk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes - ! Decide which communication scheme to use: baseline (point-to-point / alltoallv) - ! or neighbor alltoallv topology (MPI >= 3.0). Follow conventions used in other - ! swapdata implementations: baseline when any of swap_mpi/swap_sync/swap_send/swap_recv - ! is set; neighbor topology when swap_start or swap_wait is set. - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + ! error handling variables + integer(psb_ipk_) :: err_act + character(len=30) :: name info = psb_success_ name = 'psi_lswapdata_vect' call psb_erractionsave(err_act) ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) + + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -147,121 +144,168 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if - 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') + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_lswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else if (neighbor_a2av) then - call psi_lswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else + + 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) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + case(psb_comm_ineighbor_alltoallv_) + call psi_lswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_lswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_lswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_lswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') goto 9999 - end if + end select call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return end subroutine psi_lswapdata_vect - subroutine psi_lswap_baseline_vect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) - + subroutine psi_lswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! 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_) :: icomm + integer(psb_mpk_) :: np, my_rank + 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 + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti, n + logical :: do_send,do_recv + logical, parameter :: usersend=.false. + logical :: debug + character(len=20) :: name info = psb_success_ name = 'psi_lswap_baseline_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = total_recv * n - totsnd_ = total_send * n + do_send = (swap_status == psb_comm_status_start_).or.(swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_).or.(swap_status == psb_comm_status_sync_) + + total_recv_ = total_recv * n + total_send_ = total_send * n call comm_indexes%sync() - if (debug) write(*,*) me,'Internal buffer' + if (debug) write(*,*) my_rank,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) + call psb_errpush(info,name,a_err='Unfinished communication? Something is wrong....') goto 9999 end if end if - if (debug) write(*,*) me,'do_send start' call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 @@ -272,16 +316,16 @@ contains 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 + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' Gather ' + if (debug) write(*,*) my_rank,' Gather ' ! ! Then gather for sending. ! @@ -292,6 +336,16 @@ contains snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ idx_pt = snd_pt + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if call y%gth(idx_pt,nesd,comm_indexes) pnti = pnti + nerv + nesd + 3 end do @@ -301,7 +355,7 @@ contains ! call y%device_wait() - if (debug) write(*,*) me,' isend' + if (debug) write(*,*) my_rank,' isend' ! ! Then send ! @@ -309,7 +363,7 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) nerv = comm_indexes%v(pnti+psb_n_elem_recv_) @@ -317,10 +371,10 @@ contains 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 + if ((nesd>0).and.(proc_to_comm /= my_rank)) then call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -334,8 +388,8 @@ contains end if if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -345,9 +399,9 @@ contains end if call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' pnti = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) nerv = comm_indexes%v(pnti+psb_n_elem_recv_) @@ -355,9 +409,9 @@ contains snd_pt = 1+pnti+nerv+psb_n_elem_send_ rcv_pt = 1+pnti+psb_n_elem_recv_ - if (proc_to_comm /= me)then + if (proc_to_comm /= my_rank)then if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -365,25 +419,25 @@ contains end if end if if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%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 + else if (proc_to_comm == my_rank) then if (nesd /= nerv) then write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd + & '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 - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' scatter' + if (debug) write(*,*) my_rank,' scatter' pnti = 1 snd_pt = 1 rcv_pt = 1 @@ -395,29 +449,43 @@ contains 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) + if ((idx_pt < 1) .or. (nerv < 0) .or. (idx_pt+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + + if (debug) write(*,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) call y%sct(rcv_pt,nerv,comm_indexes,beta) - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do + ! ! Waited for everybody, clean up ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device ! - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' + if (debug) write(*,*) my_rank,' free buffer' call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) + if (info == 0) then + if (allocated(y%comm_handle)) call y%comm_handle%free(info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if - if (debug) write(*,*) me,' done' + if (debug) write(*,*) my_rank,' done' end if @@ -429,100 +497,223 @@ contains return end subroutine psi_lswap_baseline_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,info,data) + + + subroutine psi_lswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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 - integer(psb_ipk_), intent(in) :: flag + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status integer(psb_lpk_), intent(in) :: beta - class(psb_l_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - type(psb_ctxt_type) :: ctxt - 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 - - ! Decide which communication scheme to use: baseline (point-to-point / alltoallv) - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av - + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_lswapdata_multivect' + name = 'psi_lswap_neighbor_topology_vect' call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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 + icomm = ctxt%get_mpic() - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swap') + goto 9999 + end select - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') goto 9999 end if - 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 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait + call comm_indexes%sync() - 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 + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (baseline) then - call psi_lswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else if (neighbor_a2av) then - call psi_lswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - 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 + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + 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 + neighbor_comm_handle%comm_request = mpi_request_null + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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, & + & neighbor_comm_handle%comm_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%comm_request = mpi_request_null + else + if (neighbor_comm_handle%comm_request == mpi_request_null) then + write(psb_err_unit,*) my_rank, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', & + & neighbor_comm_handle%is_initialized + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + end if + + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((1+pnti+psb_n_elem_recv_ < 1) .or. (nerv < 0) .or. & + & (1+pnti+psb_n_elem_recv_+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 + end do + else + ! nothing to wait/scatter + end if + + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -530,255 +721,491 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_lswapdata_multivect + end subroutine psi_lswap_neighbor_topology_vect - subroutine psi_lswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_lswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type), intent(inout) :: y - integer(psb_lpk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! 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' + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n + + info = psb_success_ + name = 'psi_lswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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() + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swap') + goto 9999 + end select - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if - totrcv_ = total_recv * n - totsnd_ = total_send * n + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%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/)) + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null - call psb_realloc(num_neighbors,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%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) + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + 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 - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,comm_indexes) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into combuf using baseline-style gth calls + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data (baseline layout),', topology_total_send,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%persistent_in_flight = .false. + end if - ! - ! Then wait for device - ! + ! Wait for device (important for GPU subclasses) call y%device_wait() - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! + ! Lazy persistent-init: build the request once, then reuse with START/WAIT. + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - 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) + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 end if + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, 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 + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (baseline-style sct) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data (baseline layout),', topology_total_recv,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + rcv_pt = 1+pnti+psb_n_elem_recv_ + if (nerv > 0) then + call y%sct(rcv_pt,nerv,comm_indexes,beta) + 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 + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_lswap_neighbor_persistent_topology_vect + + + subroutine psi_lswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n + + + info = psb_success_ + name = 'psi_lswap_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! START phase: build the layout once, prepare the exposed buffer, then issue RMA. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if end if - call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%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_ + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_open = .false. 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_ + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null 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 + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(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 + end if - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Expose combuf once and keep the window around until the descriptor changes. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if - 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,comm_indexes,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 + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if ((recv_pos < 1) .or. (recv_count < 0) .or. (recv_pos+max(0,recv_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull local receive bounds error') + goto 9999 + end if - ! - ! 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 (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_lpk_, prc_rank, remote_disp, recv_count, psb_mpi_lpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do end if - if (debug) write(*,*) me,' done' end if + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if + + call y%device_wait() + end if call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return - end subroutine psi_lswap_baseline_multivect - - subroutine psi_lswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + end subroutine psi_lswap_rma_pull_vect + + subroutine psi_lswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -788,135 +1215,284 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info - ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name info = psb_success_ - name = 'psi_lswap_neighbor_topology_vect' + name = 'psi_lswap_rma_push_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 - endif - + end if icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! START phase: identical layout handling, but the remote metadata describes the receive side. if (do_start) then - if(debug) write(*,*) me,' nbr_swap: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_swap: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') goto 9999 end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - buffer_size = topology_total_send + topology_total_recv + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Keep the window alive across repetitions: it is created once and reused. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. end if - y%communication_handle = mpi_request_null - if (debug) write(*,*) me,' nbr_swap: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() - call y%device_wait() + ! Pre-post notification receives before opening the window (prevents isend/irecv ordering issues). + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do - if (debug) write(*,*) me,' nbr_swap: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_lpk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_lpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 - end if + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push data to each peer; after flush send a P2P notification so target knows data arrived. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if ((send_pos < 1) .or. (send_count < 0) .or. (send_pos+max(0,send_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push local send bounds error') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_lpk_, prc_rank, remote_disp, send_count, psb_mpi_lpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if end if + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. if (do_wait) then - - if (y%communication_handle == mpi_request_null) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - - if (debug) write(*,*) me,' nbr_swap: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 - if (debug) write(*,*) me,' nbr_swap: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if - y%communication_handle = mpi_request_null call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 - end if - if (debug) write(*,*) me,' nbr_swap: done' end if call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return - end subroutine psi_lswap_neighbor_topology_vect + end subroutine psi_lswap_rma_push_vect - subroutine psi_lswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + ! + ! + ! Subroutine: psi_lswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_lswapdata_multivect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -925,130 +1501,1246 @@ contains include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: swap_status class(psb_l_base_multivect_type), intent(inout) :: y - integer(psb_lpk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + integer(psb_lpk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data - ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act + integer(psb_mpk_) :: n, total_send_, total_recv_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name + + info = psb_success_ - name = 'psi_lswap_neighbor_topology_multivect' + name = 'psi_lswapdata_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif - icomm = ctxt%get_mpic() - - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 - - call comm_indexes%sync() + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - if (do_start) then - if(debug) write(*,*) me,' nbr_mv: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_mv: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') - goto 9999 - end if - end if + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if - buffer_size = topology_total_send + topology_total_recv + if ((swap_status /= psb_comm_status_start_) .and. (swap_status /= psb_comm_status_wait_) & + & .and. (swap_status /= psb_comm_status_unknown_)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 end if - y%communication_handle = mpi_request_null - - if (debug) write(*,*) me,' nbr_mv: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + end if - call y%device_wait() + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') + goto 9999 + end if - if (debug) write(*,*) me,' nbr_mv: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_lpk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_lpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + baseline = .false. + ineighbor_a2av = .false. + ineighbor_a2av_persistent = .false. + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + ineighbor_a2av = .true. + case(psb_comm_persistent_ineighbor_alltoallv_) + ineighbor_a2av_persistent = .true. + case(psb_comm_rma_pull_) + call psi_lswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_lswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default + baseline = .true. + end select + + if (baseline) then + call psi_lswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') goto 9999 end if + else if (ineighbor_a2av) then + call psi_lswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') + goto 9999 + end if + else if (ineighbor_a2av_persistent) then + call psi_lswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_lswapdata_multivect + + + +subroutine psi_lswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti + logical :: do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info = psb_success_ + name = 'psi_lswap_baseline_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swap') + goto 9999 + end select + + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + total_recv_ = total_recv * n + total_send_ = total_send * n + + call comm_indexes%sync() + + if (debug) write(*,*) my_rank,'Internal buffer' + if (do_send) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) my_rank,'do_send start' + call y%new_buffer(total_send_+total_recv_,info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if + baseline_comm_handle%comid = mpi_request_null + call psb_realloc(num_neighbors,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'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,baseline_comm_handle%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(*,*) my_rank,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,comm_indexes) + 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(*,*) my_rank,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= my_rank)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) + end if - if (do_wait) then - if (y%communication_handle == mpi_request_null) then + 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 (do_recv) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%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(num_neighbors,prcid,info) + + if (debug) write(*,*) my_rank,' wait' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= my_rank)then + if (nesd>0) then + call mpi_wait(baseline_comm_handle%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 + if (nerv>0) then + call mpi_wait(baseline_comm_handle%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 == my_rank) 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 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) my_rank,' scatter' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,comm_indexes,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 + ! + baseline_comm_handle%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) my_rank,' wait' + call y%device_wait() + if (debug) write(*,*) my_rank,' free buffer' + call y%free_buffer(info) + if (info == 0) then + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_lswap_baseline_multivect + + + +subroutine psi_lswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_lswap_neighbor_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (buffer_size > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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 + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + if ((topology_total_send + topology_total_recv) > 0) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_mv: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, 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 - if (debug) write(*,*) me,' nbr_mv: scattering recv data,', topology_total_recv,' elems' + ! Scatter received data to local vector positions (polymorphic for GPU) + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + end if - y%communication_handle = mpi_request_null - call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_lswap_neighbor_topology_multivect + + + +subroutine psi_lswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_lswap_neighbor_topology_multivect_persistent' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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 + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) > 0) then + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + 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,' nbr_mv: done' + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_lswap_neighbor_topology_multivect_persistent + + + subroutine psi_lswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_lswap_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_lpk_, prc_rank, remote_disp, recv_count*n, psb_mpi_lpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() end if call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_lswap_rma_pull_multivect + + + subroutine psi_lswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_lswap_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_lpk_, prc_rank, remote_disp, send_count*n, psb_mpi_lpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) return - end subroutine psi_lswap_neighbor_topology_multivect + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_lswap_rma_push_multivect + + end submodule psi_l_swapdata_impl diff --git a/base/comm/internals/psi_lswaptran.F90 b/base/comm/internals/psi_lswaptran.F90 index 8dc032399..638dadf3a 100644 --- a/base/comm/internals/psi_lswaptran.F90 +++ b/base/comm/internals/psi_lswaptran.F90 @@ -43,7 +43,7 @@ ! 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_) +! D integer(psb_lpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -59,12 +59,12 @@ ! ! ! Arguments: -! flag - integer Choose the algorithm for data exchange: +! swap_status - 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 +! swap_mpi = iand(swap_status,psb_swap_mpi_) /= 0 +! swap_sync = iand(swap_status,psb_swap_sync_) /= 0 +! swap_send = iand(swap_status,psb_swap_send_) /= 0 +! swap_recv = iand(swap_status,psb_swap_recv_) /= 0 ! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_sync): use PSB_SND and PSB_RCV in ! synchronized pairs @@ -77,9 +77,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y - type(psb_l_vect_type) The data area +! beta - real Choose overwrite or sum. +! y - type(psb_d_vect_type) The data area ! desc_a - type(psb_desc_type). The communication descriptor. +! our own internal allocation. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -91,8 +92,9 @@ ! submodule (psi_l_comm_v_mod) psi_l_swaptran_impl use psb_base_mod + use psb_comm_factory_mod contains - module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_lswaptran_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -102,23 +104,19 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta - class(psb_l_base_vect_type), intent(inout) :: y - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ - class(psb_i_base_vect_type), pointer :: comm_indexes - character(len=20) :: name - - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av - + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=20) :: name info = psb_success_ name = 'psi_lswaptran_vect' @@ -134,7 +132,7 @@ contains endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -145,40 +143,71 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - 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 + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if end if - if (baseline) then - call psi_ltran_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else if (neighbor_a2av) then - call psi_ltran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_ltran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_ltran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_ltran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_ltran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_ltran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select + call psb_erractionrestore(err_act) return @@ -187,9 +216,21 @@ contains return end subroutine psi_lswaptran_vect - - subroutine psi_ltran_baseline_vect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + ! + ! + ! Subroutine: psi_ltran_baseline_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_baseline_vect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -200,11 +241,12 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals @@ -212,6 +254,7 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_) :: icomm integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& @@ -224,29 +267,35 @@ contains call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then - info = psb_err_context_error_ + info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -256,17 +305,17 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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_ @@ -275,7 +324,7 @@ contains 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do @@ -287,13 +336,13 @@ contains pnti = 1 snd_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + call y%gth(idx_pt,nerv,idx) pnti = pnti + nerv + nesd + 3 end do @@ -311,18 +360,18 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -337,7 +386,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -349,17 +398,17 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -367,7 +416,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -390,22 +439,22 @@ contains snd_pt = 1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -414,7 +463,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -433,7 +484,193 @@ contains end subroutine psi_ltran_baseline_vect - subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,info,data) + + + subroutine psi_ltran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_ltran_neighbor_topology_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 + + icomm = ctxt%get_mpic() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, & + & a_err='neighbor_topology_init') + goto 9999 + end if + end if + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + neighbor_comm_handle%comm_request = mpi_request_null + + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_lpk_, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_lpk_, & + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) + + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) me,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_ltran_neighbor_topology_vect + + + + + ! + ! + ! + ! + ! Subroutine: psi_lswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_lswaptran_multivect(swap_status,beta,y,desc_a,info,data) + #ifdef PSB_MPI_MOD use mpi #endif @@ -442,8 +679,8 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_multivect_type), intent(inout) :: y type(psb_desc_type),target :: desc_a integer(psb_ipk_), intent(out) :: info @@ -456,8 +693,8 @@ contains class(psb_i_base_vect_type), pointer :: comm_indexes character(len=20) :: name - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av + integer(psb_ipk_) :: setflag + info = psb_success_ name = 'psi_lswaptran_multivect' @@ -467,7 +704,7 @@ contains icomm = ctxt%get_mpic() call psb_info(ctxt,me,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif @@ -484,40 +721,80 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if - 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 + setflag = swap_status + if (swap_status == psb_swap_start_) then + setflag = psb_comm_status_start_ + else if (swap_status == psb_swap_wait_) then + setflag = psb_comm_status_wait_ + else if ((iand(swap_status, psb_swap_send_) /= 0) .or. (iand(swap_status, psb_swap_recv_) /= 0) .or. & + & (iand(swap_status, psb_swap_mpi_) /= 0) .or. (iand(swap_status, psb_swap_sync_) /= 0)) then + setflag = psb_comm_status_sync_ + end if - if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + if ((setflag /= psb_comm_status_start_) .and. (setflag /= psb_comm_status_wait_) .and. & + & (setflag /= psb_comm_status_sync_)) then info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') + call psb_errpush(info,name,a_err='Invalid swap_status') goto 9999 end if - if (baseline) then - call psi_ltran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else if (neighbor_a2av) then - call psi_ltran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) - if (info /= psb_success_) goto 9999 - else - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + call y%comm_handle%set_swap_status(setflag, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_ltran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_ltran_neighbor_persistent_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_ltran_rma_pull_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_ltran_rma_push_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_ltran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select + call psb_erractionrestore(err_act) return @@ -526,9 +803,8 @@ contains return end subroutine psi_lswaptran_multivect - - subroutine psi_ltran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + subroutine psi_ltran_baseline_multivect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -539,18 +815,20 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta - class(psb_l_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + integer(psb_ipk_), intent(in) :: swap_status integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type), intent(inout) :: y + integer(psb_lpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle ! 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(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& @@ -559,7 +837,7 @@ contains character(len=20) :: name info = psb_success_ - name = 'psi_ltran_baseline_multivect' + name = 'psi_ltran_vidx_multivect' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then @@ -569,24 +847,30 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -596,25 +880,25 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -629,10 +913,10 @@ contains snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + 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 @@ -651,17 +935,17 @@ contains pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -677,7 +961,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -691,14 +975,14 @@ contains pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_long_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -706,7 +990,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -731,14 +1015,14 @@ contains snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 @@ -748,7 +1032,7 @@ contains ! ! Waited for com, cleanup comid ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -757,7 +1041,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -776,38 +1062,40 @@ contains end subroutine psi_ltran_baseline_multivect - subroutine psi_ltran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) - + subroutine psi_ltran_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_vect_type) :: y - integer(psb_lpk_) :: beta - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + info = psb_success_ - name = 'psi_ltran_neighbor_topology_vect' + name = 'psi_ltran_neighbor_topology_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -816,25 +1104,43 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, & + & a_err='neighbor_topology_init') goto 9999 end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -842,68 +1148,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() - - if (debug) write(*,*) me,' nbr_tran: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_lpk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_lpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_lpk_, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_lpk_, & + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran: done' - end if + if (debug) write(*,*) me,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -911,144 +1230,1338 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_ltran_neighbor_topology_vect + end subroutine psi_ltran_neighbor_topology_multivect - subroutine psi_ltran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + subroutine psi_ltran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type) :: y - integer(psb_lpk_) :: beta - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info - ! locals - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + integer(psb_mpk_) :: icomm, np, my_rank, iret + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name info = psb_success_ - name = 'psi_ltran_neighbor_topology_multivect' + name = 'psi_ltran_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif - icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() if (do_start) then - if(debug) write(*,*) me,' nbr_mv: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_mv: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if - - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv buffer_size = topology_total_send + topology_total_recv - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_mv: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes (we "send" recv data) + if (debug) write(*,*) my_rank,' tran_persistent_vect: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if call y%device_wait() - if (debug) write(*,*) me,' nbr_mv: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_lpk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_lpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv counts in alltoallv_init + ! send = recv_indexes data with recv_counts/displs + ! recv = into send_indexes area with send_counts/displs + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_lpk_, & + & y%combuf(topology_total_recv + 1), & + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_lpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if end if - end if + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start if (do_wait) then - if (y%communication_handle == mpi_request_null) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. - if (debug) write(*,*) me,' nbr_mv: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_vect: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) end if - if (debug) write(*,*) me,' nbr_mv: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_neighbor_persistent_topology_vect + + + subroutine psi_ltran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! Effective sizes for transpose: + ! eff_send = total_recv (we expose recv_indexes data) + ! eff_recv = total_send (we GET into the send_indexes area) + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ltran_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if - y%communication_handle = mpi_request_null + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_lpk_, prc_rank, remote_disp, recv_count, psb_mpi_lpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_rma_pull_vect + + + subroutine psi_ltran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ltran_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push our recv_indexes data to each peer's send_indexes area; notify after flush. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_lpk_, prc_rank, remote_disp, send_count, psb_mpi_lpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_rma_push_vect + + + subroutine psi_ltran_neighbor_persistent_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret, n + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_ltran_neighbor_persistent_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor multivect swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') goto 9999 end if - if (debug) write(*,*) me,' nbr_mv: done' + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:total_recv_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv in alltoallv_init + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & psb_mpi_lpk_, & + & y%combuf(total_recv_ + 1), & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_lpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(total_recv_+1:total_recv_+total_send_), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_neighbor_persistent_topology_multivect + + + subroutine psi_ltran_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ltran_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull multivect') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_lpk_, prc_rank, remote_disp, recv_count*n, psb_mpi_lpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_rma_pull_multivect + + + subroutine psi_ltran_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta + class(psb_l_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ltran_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push multivect') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_lpk_, prc_rank, remote_disp, send_count*n, psb_mpi_lpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) return - end subroutine psi_ltran_neighbor_topology_multivect + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_rma_push_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 a660e2fde..dc2137a00 100644 --- a/base/comm/internals/psi_movrl_restr_a.f90 +++ b/base/comm/internals/psi_movrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_movrl_save_a.f90 b/base/comm/internals/psi_movrl_save_a.f90 index d9d0e603b..d728ed718 100644 --- a/base/comm/internals/psi_movrl_save_a.f90 +++ b/base/comm/internals/psi_movrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_movrl_upd_a.f90 b/base/comm/internals/psi_movrl_upd_a.f90 index f31d4cfa1..dfa070a62 100644 --- a/base/comm/internals/psi_movrl_upd_a.f90 +++ b/base/comm/internals/psi_movrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_mswapdata_a.F90 b/base/comm/internals/psi_mswapdata_a.F90 index 7a00f36c1..335df8ed3 100644 --- a/base/comm/internals/psi_mswapdata_a.F90 +++ b/base/comm/internals/psi_mswapdata_a.F90 @@ -39,7 +39,7 @@ ! 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_) +! D integer(psb_mpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -70,10 +70,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:,:) - integer The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do +! 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 @@ -97,13 +97,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -165,12 +166,13 @@ integer(psb_mpk_), target :: work(:) #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n 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 + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -348,7 +350,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_mpk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -370,7 +372,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag + 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,& @@ -401,7 +403,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -510,7 +512,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf ! 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_) + ! D integer(psb_mpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -541,10 +543,10 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf ! ! ! n - integer Number of columns in Y - ! beta - integer Choose overwrite or sum. - ! y(:) - integer The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - integer Buffer space. If not sufficient, will do + ! 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 @@ -565,12 +567,13 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -648,7 +651,8 @@ 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_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -830,7 +834,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & psb_mpi_mpk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -852,7 +856,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag + p2ptag = psb_double_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -882,7 +886,7 @@ integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_mswaptran_a.F90 b/base/comm/internals/psi_mswaptran_a.F90 index 07672d390..051209e70 100644 --- a/base/comm/internals/psi_mswaptran_a.F90 +++ b/base/comm/internals/psi_mswaptran_a.F90 @@ -30,7 +30,7 @@ ! ! ! -! File: psi_mswaptran.F90 +! File: psi_mswaptran_a.F90 ! ! Subroutine: psi_mswaptranm ! Implements the data exchange among processes. This is similar to Xswapdata, but @@ -43,7 +43,7 @@ ! 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_) +! D integer(psb_mpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -74,10 +74,10 @@ ! ! ! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:,:) - integer The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do +! 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 @@ -101,13 +101,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -149,7 +150,7 @@ contains goto 9999 end if - call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + 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) @@ -174,7 +175,8 @@ contains 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_), intent(inout) :: y(:,:) + integer(psb_mpk_), intent(in) :: beta integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -360,7 +362,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & psb_mpi_mpk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -383,7 +385,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_mpk_,prcid(i),& @@ -413,7 +415,7 @@ contains nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -525,7 +527,7 @@ contains ! 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_) + ! D integer(psb_mpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -556,10 +558,10 @@ contains ! ! ! n - integer Number of columns in Y - ! beta - integer Choose overwrite or sum. - ! y(:) - integer The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - integer Buffer space. If not sufficient, will do + ! 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 @@ -579,12 +581,13 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -659,7 +662,8 @@ contains 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_), intent(inout) :: y(:) + integer(psb_mpk_), intent(in) :: beta integer(psb_mpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -845,7 +849,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & psb_mpi_mpk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -868,7 +872,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & psb_mpi_mpk_,prcid(i),& @@ -896,7 +900,7 @@ contains 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_sovrl_restr.f90 b/base/comm/internals/psi_sovrl_restr.f90 index 1ce96355b..14dc55ce0 100644 --- a/base/comm/internals/psi_sovrl_restr.f90 +++ b/base/comm/internals/psi_sovrl_restr.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_sovrl_restr_a.f90 b/base/comm/internals/psi_sovrl_restr_a.f90 index 2e1d53ae7..66960ef41 100644 --- a/base/comm/internals/psi_sovrl_restr_a.f90 +++ b/base/comm/internals/psi_sovrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_sovrl_save.f90 b/base/comm/internals/psi_sovrl_save.f90 index cd259f721..b5d4b3c75 100644 --- a/base/comm/internals/psi_sovrl_save.f90 +++ b/base/comm/internals/psi_sovrl_save.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_sovrl_save_a.f90 b/base/comm/internals/psi_sovrl_save_a.f90 index aa3468e02..12e5d2aad 100644 --- a/base/comm/internals/psi_sovrl_save_a.f90 +++ b/base/comm/internals/psi_sovrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_sovrl_upd.f90 b/base/comm/internals/psi_sovrl_upd.f90 index 2ee13aa68..acf68554f 100644 --- a/base/comm/internals/psi_sovrl_upd.f90 +++ b/base/comm/internals/psi_sovrl_upd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_sovrl_upd_a.f90 b/base/comm/internals/psi_sovrl_upd_a.f90 index 64d856318..68a0e3357 100644 --- a/base/comm/internals/psi_sovrl_upd_a.f90 +++ b/base/comm/internals/psi_sovrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index c023724a5..d5e54af42 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -41,7 +41,7 @@ ! 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_) +! D real(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -53,31 +53,22 @@ ! is scattered in the owned indices, and BETA=1. ! The first routine picks the desired exchange index list and passes it to the second. ! This version works on encapsulated vectors, and uses their methods to do GTH and SCT, -! so that special versions (i.e. GPU vectors can override them +! so that special versions (i.e. GPU vectors can override them) ! ! 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) +! swap_status - integer Swap status selector. +! It is interpreted as a communication status: +! psb_comm_status_start_ -> START phase +! psb_comm_status_wait_ -> WAIT phase +! psb_comm_status_unknown_ -> START+WAIT +! The communication scheme is selected from +! y%comm_handle%comm_type. ! ! ! n - integer Number of columns in Y -! beta - real Choose overwrite or sum. +! beta - real Choose overwrite or sum. ! y - type(psb_@x@_vect_type) The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! our own internal allocation. +! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -91,9 +82,16 @@ submodule (psi_s_comm_v_mod) psi_s_swapdata_impl use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_ use psb_base_mod + use psb_error_mod, only: psb_get_debug_level, psb_get_debug_unit, psb_debug_ext_ + 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_, & + & psb_comm_handle_type + use psb_comm_rma_mod, only: psb_comm_rma_handle + use psb_comm_factory_mod + contains - module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_sswapdata_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -102,28 +100,24 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - real(psb_spk_), intent(in) :: beta - class(psb_s_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ + 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 + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent ! error handling variables - integer(psb_ipk_) :: err_act - integer(psb_mpk_) :: me, np - character(len=30) :: name - + integer(psb_ipk_) :: err_act + character(len=30) :: name info = psb_success_ name = 'psi_sswapdata_vect' @@ -131,7 +125,7 @@ contains ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -152,163 +146,207 @@ contains call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - 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') + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_sswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + + 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) 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_sswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + case(psb_comm_ineighbor_alltoallv_) + call psi_sswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + call psb_errpush(info,name,a_err='neighbor nonblocking swap') goto 9999 end if - else + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_sswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_sswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_sswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') goto 9999 - end if + end select call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(ctxt,err_act) - return end subroutine psi_sswapdata_vect - - - -! -! subroutine psi_sswap_baseline_vect -! This performs Isend/Irecv as a baseline communication mode -! -subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) - + subroutine psi_sswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: swap_status real(psb_spk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! 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_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& - & 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' + & snd_pt, rcv_pt, pnti, n + logical :: do_send,do_recv + logical, parameter :: usersend=.false. + logical :: debug + character(len=20) :: name + + info = psb_success_ + name = 'psi_sswap_baseline_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv + do_send = (swap_status == psb_comm_status_start_).or.(swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_).or.(swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n - call idx%sync() + call comm_indexes%sync() - if (debug) write(*,*) me,'Internal buffer' + if (debug) write(*,*) my_rank,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) + call psb_errpush(info,name,a_err='Unfinished communication? Something is wrong....') 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(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(comm_indexes%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' Gather ' + if (debug) write(*,*) my_rank,' Gather ' ! ! Then gather for sending. ! pnti = 1 do i=1, num_neighbors - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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) + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(idx_pt,nesd,comm_indexes) pnti = pnti + nerv + nesd + 3 end do @@ -317,7 +355,7 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & ! call y%device_wait() - if (debug) write(*,*) me,' isend' + if (debug) write(*,*) my_rank,' isend' ! ! Then send ! @@ -325,18 +363,18 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((nesd>0).and.(proc_to_comm /= my_rank)) then call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -350,8 +388,8 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & end if if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -361,19 +399,19 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & end if call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' pnti = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 (proc_to_comm /= my_rank)then if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -381,59 +419,73 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & end if end if if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%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 + else if (proc_to_comm == my_rank) then if (nesd /= nerv) then write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd + & '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 - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' scatter' + if (debug) write(*,*) my_rank,' scatter' pnti = 1 snd_pt = 1 rcv_pt = 1 do i=1, num_neighbors - 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_) + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((idx_pt < 1) .or. (nerv < 0) .or. (idx_pt+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + + if (debug) write(*,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 end do + ! ! Waited for everybody, clean up ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device ! - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' + if (debug) write(*,*) my_rank,' free buffer' call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) + if (info == 0) then + if (allocated(y%comm_handle)) call y%comm_handle%free(info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if - if (debug) write(*,*) me,' done' + if (debug) write(*,*) my_rank,' done' end if @@ -443,13 +495,12 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, & 9999 call psb_error_handler(ctxt,err_act) return - -end subroutine psi_sswap_baseline_vect + end subroutine psi_sswap_baseline_vect -subroutine psi_sswap_neighbor_topology_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_sswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -458,276 +509,477 @@ subroutine psi_sswap_neighbor_topology_vect(ctxt,flag,beta,y,idx, & include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type), intent(inout) :: y - real(psb_spk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name - - - info = psb_success_ - name = 'psi_sswap_nbr_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 - - icomm = ctxt%get_mpic() - - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 - - call idx%sync() - - ! --------------------------------------------------------- - ! START phase: build topology (if needed), gather, post MPI - ! --------------------------------------------------------- - if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - ! Lazy initialization: build the topology on first call - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') - goto 9999 - end if - end if - - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info - ! Buffer layout: - ! combuf(1 : total_send) = send area - ! combuf(total_send+1 : total_send+total_recv) = recv area - buffer_size = topology_total_send + topology_total_recv + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + info = psb_success_ + name = 'psi_sswap_neighbor_topology_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if - y%communication_handle = mpi_request_null + endif - ! Gather send data into contiguous send buffer (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + icomm = ctxt%get_mpic() - ! Wait for device (important for GPU subclasses) - call y%device_wait() + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swap') + goto 9999 + end select - ! Post non-blocking neighborhood alltoallv - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_r_spk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_r_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then + if(swap_status == psb_comm_status_unknown_) then info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') goto 9999 end if - end if ! do_start + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + 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 + neighbor_comm_handle%comm_request = mpi_request_null + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%comm_request = mpi_request_null + end if - ! --------------------------------------------------------- - ! WAIT phase: complete MPI, scatter received data - ! --------------------------------------------------------- - if (do_wait) then + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (y%communication_handle == mpi_request_null) then - ! No matching start? Something is wrong - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 - end if + ! Post non-blocking neighborhood alltoallv + 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, & + & neighbor_comm_handle%comm_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%comm_request = mpi_request_null + else + if (neighbor_comm_handle%comm_request == mpi_request_null) then + write(psb_err_unit,*) my_rank, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', & + & neighbor_comm_handle%is_initialized + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + end if - ! Wait for the non-blocking collective to complete - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 - end if + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if - ! Scatter received data to local vector positions (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((1+pnti+psb_n_elem_recv_ < 1) .or. (nerv < 0) .or. & + & (1+pnti+psb_n_elem_recv_+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 + end do + else + ! nothing to wait/scatter + end if - ! Clean up - y%communication_handle = mpi_request_null - call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 - end if - if (debug) write(*,*) me,' nbr_vect: done' + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' - end if ! do_wait + end if ! do_wait - 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_neighbor_topology_vect - + return + end subroutine psi_sswap_neighbor_topology_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,info,data) + subroutine psi_sswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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 - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type), intent(inout) :: y - real(psb_spk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - 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 - + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_sswapdata_multivect' + name = 'psi_sswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - - - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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 + icomm = ctxt%get_mpic() - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swap') goto 9999 - end if - - 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 + end select - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait - - 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') + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') goto 9999 end if + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - if (baseline) then - call psi_sswap_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') + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') goto 9999 end if - else if (neighbor_a2av) then - call psi_sswap_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 + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into combuf using baseline-style gth calls + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data (baseline layout),', topology_total_send,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%persistent_in_flight = .false. 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 - -9999 call psb_error_handler(ctxt,err_act) - - return - end subroutine psi_sswapdata_multivect + ! Wait for device (important for GPU subclasses) + call y%device_wait() + ! Lazy persistent-init: build the request once, then reuse with START/WAIT. + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (baseline-style sct) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data (baseline layout),', topology_total_recv,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + rcv_pt = 1+pnti+psb_n_elem_recv_ + if (nerv > 0) then + call y%sct(rcv_pt,nerv,comm_indexes,beta) + end if + pnti = pnti + nerv + nesd + 3 + end do + end if + + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_sswap_neighbor_persistent_topology_vect -subroutine psi_sswap_baseline_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_sswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -736,242 +988,1105 @@ subroutine psi_sswap_baseline_multivect(ctxt,flag,beta,y,idx, & include 'mpif.h' #endif - 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 - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n - ! 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, total_send_, total_recv_,& - & 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_sswap_baseline_multivect' + name = 'psi_sswap_rma_pull_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 - endif + end if 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 + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! START phase: build the layout once, prepare the exposed buffer, then issue RMA. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if - total_recv_ = total_recv * n - total_send_ = total_send * n + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if - call idx%sync() + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if - 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/)) + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Expose combuf once and keep the window around until the descriptor changes. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_ready = .true. end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null - call psb_realloc(num_neighbors,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - do i=1, num_neighbors - 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) + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) 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 = total_recv_+1 - rcv_pt = 1 - do i=1, num_neighbors - 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 + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if ((recv_pos < 1) .or. (recv_count < 0) .or. (recv_pos+max(0,recv_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull local receive bounds error') + goto 9999 + end if + + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if - ! - ! Then wait for device - ! call y%device_wait() + end if - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! + call psb_erractionrestore(err_act) + return - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, num_neighbors - 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) +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_sswap_rma_pull_vect + + + subroutine psi_sswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_sswap_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! START phase: identical layout handling, but the remote metadata describes the receive side. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') 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 + 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 + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if end if - call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, num_neighbors - 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_ + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Keep the window alive across repetitions: it is created once and reused. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window (prevents isend/irecv ordering issues). + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ + end do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push data to each peer; after flush send a P2P notification so target knows data arrived. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if ((send_pos < 1) .or. (send_count < 0) .or. (send_pos+max(0,send_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push local send bounds error') + goto 9999 + end if + + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_spk_, prc_rank, remote_disp, send_count, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-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 do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if + + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_sswap_rma_push_vect + + + + ! + ! + ! Subroutine: psi_sswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_sswapdata_multivect(swap_status,beta,y,desc_a,info,data) +#ifdef PSB_MPI_MOD + use mpi +#endif + implicit none +#ifdef PSB_MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: swap_status + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act + integer(psb_mpk_) :: n, total_send_, total_recv_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name + + + info = psb_success_ + name = 'psi_sswapdata_multivect' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,my_rank,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_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + if ((swap_status /= psb_comm_status_start_) .and. (swap_status /= psb_comm_status_wait_) & + & .and. (swap_status /= psb_comm_status_unknown_)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if + + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') + goto 9999 + end if + + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + baseline = .false. + ineighbor_a2av = .false. + ineighbor_a2av_persistent = .false. + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + ineighbor_a2av = .true. + case(psb_comm_persistent_ineighbor_alltoallv_) + ineighbor_a2av_persistent = .true. + case(psb_comm_rma_pull_) + call psi_sswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_sswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default + baseline = .true. + end select + + if (baseline) then + call psi_sswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + else if (ineighbor_a2av) then + call psi_sswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') + goto 9999 + end if + else if (ineighbor_a2av_persistent) then + call psi_sswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_sswapdata_multivect + + + + +subroutine psi_sswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti + logical :: do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info = psb_success_ + name = 'psi_sswap_baseline_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swap') + goto 9999 + end select + + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + total_recv_ = total_recv * n + total_send_ = total_send * n + + call comm_indexes%sync() + + if (debug) write(*,*) my_rank,'Internal buffer' + if (do_send) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) my_rank,'do_send start' + call y%new_buffer(total_send_+total_recv_,info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + baseline_comm_handle%comid = mpi_request_null + call psb_realloc(num_neighbors,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'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,baseline_comm_handle%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(*,*) my_rank,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,comm_indexes) + 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(*,*) my_rank,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= my_rank)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%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 (do_recv) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%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(num_neighbors,prcid,info) + + if (debug) write(*,*) my_rank,' wait' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= my_rank)then + if (nesd>0) then + call mpi_wait(baseline_comm_handle%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 - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(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 + if (nerv>0) then + call mpi_wait(baseline_comm_handle%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 == my_rank) 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 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) my_rank,' scatter' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,comm_indexes,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 + ! + baseline_comm_handle%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) my_rank,' wait' + call y%device_wait() + if (debug) write(*,*) my_rank,' free buffer' + call y%free_buffer(info) + if (info == 0) then + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_sswap_baseline_multivect + + + +subroutine psi_sswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_sswap_neighbor_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (buffer_size > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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 + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = total_recv_+1 - rcv_pt = 1 - do i=1, num_neighbors - 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_ + end if ! do_start - 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 + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then - ! - ! 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) + if ((topology_total_send + topology_total_recv) > 0) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - if (debug) write(*,*) me,' done' + else + neighbor_comm_handle%comm_request = mpi_request_null end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - call psb_erractionrestore(err_act) - return + ! Wait for the non-blocking collective to complete + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, 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 + + ! Scatter received data to local vector positions (polymorphic for GPU) + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + end if + + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_sswap_baseline_multivect +end subroutine psi_sswap_neighbor_topology_multivect -subroutine psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) +subroutine psi_sswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -980,28 +2095,32 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_) :: 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 - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name info = psb_success_ - name = 'psi_sswap_neighbor_topology_multivect' + name = 'psi_sswap_neighbor_topology_multivect_persistent' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -1009,70 +2128,136 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & endif icomm = ctxt%get_mpic() + n = y%get_ncols() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swap') + goto 9999 + end select - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) - call idx%sync() + call comm_indexes%sync() ! --------------------------------------------------------- ! START phase: build topology (if needed), gather, post MPI ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - ! Lazy initialization: build the topology on first call - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & & ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if - - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv ! Buffer layout: ! combuf(1 : total_send) = send area ! combuf(total_send+1 : total_send+total_recv) = recv area - buffer_size = topology_total_send + topology_total_recv + buffer_size = total_send_ + total_recv_ - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + else + neighbor_comm_handle%persistent_in_flight = .false. end if - y%communication_handle = mpi_request_null - - ! Gather send data into contiguous send buffer (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) ! Wait for device (important for GPU subclasses) call y%device_wait() - ! Post non-blocking neighborhood alltoallv - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_r_spk_, & - & y%combuf(topology_total_send + 1), & ! recv buffer - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_r_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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 + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. end if end if ! do_start @@ -1082,42 +2267,38 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then - ! No matching start? Something is wrong - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 - end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + if ((topology_total_send + topology_total_recv) > 0) then + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if - ! Wait for the non-blocking collective to complete - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 - end if + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. - ! Scatter received data to local vector positions (polymorphic for GPU) - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & & beta) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if - - ! Clean up - y%communication_handle = mpi_request_null call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 - end if - if (debug) write(*,*) me,' nbr_vect: done' + if (debug) write(*,*) my_rank,' nbr_vect: done' end if ! do_wait @@ -1127,7 +2308,438 @@ subroutine psi_sswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_sswap_neighbor_topology_multivect +end subroutine psi_sswap_neighbor_topology_multivect_persistent + + + subroutine psi_sswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_sswap_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_sswap_rma_pull_multivect + + + subroutine psi_sswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_sswap_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_sswap_rma_push_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 23da82246..32083f3f4 100644 --- a/base/comm/internals/psi_sswapdata_a.F90 +++ b/base/comm/internals/psi_sswapdata_a.F90 @@ -39,7 +39,7 @@ ! 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_) +! D real(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -97,13 +97,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -165,12 +166,13 @@ real(psb_spk_), target :: work(:) #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n 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 + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -348,7 +350,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_r_spk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -370,7 +372,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag + 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,& @@ -401,7 +403,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -510,7 +512,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf ! 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_) + ! D real(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -565,12 +567,13 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + integer(psb_ipk_), intent(in) :: flag + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -648,7 +651,8 @@ 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_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -830,7 +834,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& & psb_mpi_r_spk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) @@ -852,7 +856,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag if ((nesd>0).and.(proc_to_comm /= me)) then if (usersend) then @@ -882,7 +886,7 @@ real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index 452e31924..8b47a2988 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -43,7 +43,7 @@ ! 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_) +! D real(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -59,12 +59,12 @@ ! ! ! Arguments: -! flag - integer Choose the algorithm for data exchange: +! swap_status - 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 +! swap_mpi = iand(swap_status,psb_swap_mpi_) /= 0 +! swap_sync = iand(swap_status,psb_swap_sync_) /= 0 +! swap_send = iand(swap_status,psb_swap_send_) /= 0 +! swap_recv = iand(swap_status,psb_swap_recv_) /= 0 ! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_sync): use PSB_SND and PSB_RCV in ! synchronized pairs @@ -78,8 +78,9 @@ ! ! n - integer Number of columns in Y ! beta - real Choose overwrite or sum. -! y - type(psb_s_vect_type) The data area +! y - type(psb_d_vect_type) The data area ! desc_a - type(psb_desc_type). The communication descriptor. +! our own internal allocation. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -91,8 +92,9 @@ ! submodule (psi_s_comm_v_mod) psi_s_swaptran_impl use psb_base_mod + use psb_comm_factory_mod contains - module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_sswaptran_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -102,23 +104,19 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - real(psb_spk_), intent(in) :: beta - class(psb_s_base_vect_type), intent(inout) :: y - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ - 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 - logical :: baseline, neighbor_a2av + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=20) :: name info = psb_success_ name = 'psi_sswaptran_vect' @@ -134,7 +132,7 @@ contains endif if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_invalid_cd_state_ + info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 endif @@ -151,39 +149,64 @@ contains goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if - 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') + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_stran_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') + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_stran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') goto 9999 end if - else if (neighbor_a2av) then - call psi_stran_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') + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_stran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') 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 + case(psb_comm_rma_pull_) + call psi_stran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_stran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_stran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -193,9 +216,21 @@ contains return end subroutine psi_sswaptran_vect - - module subroutine psi_stran_baseline_vect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + ! + ! + ! Subroutine: psi_stran_baseline_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_baseline_vect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -206,11 +241,12 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(in) :: swap_status real(psb_spk_), intent(in) :: beta class(psb_s_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals @@ -218,6 +254,7 @@ contains integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret integer(psb_mpk_) :: icomm integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& @@ -225,8 +262,8 @@ contains logical, parameter :: usersend=.false., debug=.false. character(len=20) :: name - info=psb_success_ - name='psi_stran_baseline_vect' + info = psb_success_ + name = 'psi_stran_baseline_vect' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then @@ -236,23 +273,29 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -262,17 +305,17 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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_ @@ -281,7 +324,7 @@ contains 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do @@ -293,13 +336,13 @@ contains pnti = 1 snd_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + call y%gth(idx_pt,nerv,idx) pnti = pnti + nerv + nesd + 3 end do @@ -317,18 +360,18 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -343,7 +386,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -355,17 +398,17 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -373,7 +416,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -396,22 +439,22 @@ contains snd_pt = 1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -420,7 +463,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -440,28 +485,31 @@ contains - subroutine psi_stran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + + subroutine psi_stran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(in) :: swap_status real(psb_spk_), intent(in) :: beta class(psb_s_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. @@ -471,7 +519,7 @@ contains info = psb_success_ name = 'psi_stran_neighbor_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -480,17 +528,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_vect: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -498,8 +559,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -507,70 +572,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_vect: gathering (recv) data,', topology_total_recv,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_r_spk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & & psb_mpi_r_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_vect: scattering (send) data,', topology_total_send,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_vect: done' + if (debug) write(*,*) me,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -583,10 +659,6 @@ contains - - - - ! ! ! @@ -597,7 +669,7 @@ contains ! Takes care of Y an encaspulated multivector. ! ! - module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data) + module subroutine psi_sswaptran_multivect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -607,7 +679,7 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(in) :: swap_status real(psb_spk_), intent(in) :: beta class(psb_s_base_multivect_type), intent(inout) :: y type(psb_desc_type),target :: desc_a @@ -621,9 +693,8 @@ contains 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 - logical :: baseline, neighbor_a2av + integer(psb_ipk_) :: setflag + info = psb_success_ name = 'psi_sswaptran_multivect' @@ -633,7 +704,7 @@ contains icomm = ctxt%get_mpic() call psb_info(ctxt,me,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif @@ -656,40 +727,74 @@ contains goto 9999 end if - 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 + setflag = swap_status + if (swap_status == psb_swap_start_) then + setflag = psb_comm_status_start_ + else if (swap_status == psb_swap_wait_) then + setflag = psb_comm_status_wait_ + else if ((iand(swap_status, psb_swap_send_) /= 0) .or. (iand(swap_status, psb_swap_recv_) /= 0) .or. & + & (iand(swap_status, psb_swap_mpi_) /= 0) .or. (iand(swap_status, psb_swap_sync_) /= 0)) then + setflag = psb_comm_status_sync_ + end if - if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + if ((setflag /= psb_comm_status_start_) .and. (setflag /= psb_comm_status_wait_) .and. & + & (setflag /= psb_comm_status_sync_)) then info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') + call psb_errpush(info,name,a_err='Invalid swap_status') goto 9999 end if - if (baseline) then - call psi_stran_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') + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 end if - else if (neighbor_a2av) then - call psi_stran_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') + end if + + call y%comm_handle%set_swap_status(setflag, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_stran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_stran_neighbor_persistent_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_stran_rma_pull_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_stran_rma_push_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_stran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select + call psb_erractionrestore(err_act) return @@ -698,9 +803,8 @@ contains return end subroutine psi_sswaptran_multivect - - subroutine psi_stran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + subroutine psi_stran_baseline_multivect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -711,19 +815,20 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes + real(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info - + class(psb_comm_handle_type), intent(inout) :: comm_handle ! 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(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& @@ -731,8 +836,8 @@ contains logical, parameter :: usersend=.false., debug=.false. character(len=20) :: name - info=psb_success_ - name='psi_swap_tran' + info = psb_success_ + name = 'psi_stran_vidx_multivect' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then @@ -742,24 +847,30 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) total_recv_ = total_recv * n total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -769,25 +880,25 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -802,10 +913,10 @@ contains snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + 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 @@ -824,17 +935,17 @@ contains pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -850,7 +961,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -864,14 +975,14 @@ contains pnti = 1 snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -879,7 +990,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -904,14 +1015,14 @@ contains snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 @@ -921,7 +1032,7 @@ contains ! ! Waited for com, cleanup comid ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -930,7 +1041,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -949,29 +1062,30 @@ contains end subroutine psi_stran_baseline_multivect - - subroutine psi_stran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_stran_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(in) :: swap_status real(psb_spk_), intent(in) :: beta class(psb_s_base_multivect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. @@ -979,9 +1093,9 @@ contains info = psb_success_ - name = 'psi_stran_neighbor_topology_vect' + name = 'psi_stran_neighbor_topology_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -990,17 +1104,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_vect: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -1008,8 +1135,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -1017,70 +1148,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_vect: gathering (recv) data,', topology_total_recv,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_r_spk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & & psb_mpi_r_spk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_vect: scattering (send) data,', topology_total_send,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_vect: done' + if (debug) write(*,*) me,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -1092,4 +1234,1334 @@ contains + subroutine psi_stran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_stran_neighbor_persistent_topology_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes (we "send" recv data) + if (debug) write(*,*) my_rank,' tran_persistent_vect: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv counts in alltoallv_init + ! send = recv_indexes data with recv_counts/displs + ! recv = into send_indexes area with send_counts/displs + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_r_spk_, & + & y%combuf(topology_total_recv + 1), & + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_r_spk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_vect: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_neighbor_persistent_topology_vect + + + subroutine psi_stran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! Effective sizes for transpose: + ! eff_send = total_recv (we expose recv_indexes data) + ! eff_recv = total_send (we GET into the send_indexes area) + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_stran_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_rma_pull_vect + + + subroutine psi_stran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_stran_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push our recv_indexes data to each peer's send_indexes area; notify after flush. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_spk_, prc_rank, remote_disp, send_count, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_rma_push_vect + + + subroutine psi_stran_neighbor_persistent_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret, n + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_stran_neighbor_persistent_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor multivect swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:total_recv_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv in alltoallv_init + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & psb_mpi_r_spk_, & + & y%combuf(total_recv_ + 1), & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_r_spk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(total_recv_+1:total_recv_+total_send_), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_neighbor_persistent_topology_multivect + + + subroutine psi_stran_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_stran_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull multivect') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_spk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_rma_pull_multivect + + + subroutine psi_stran_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta + class(psb_s_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_stran_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push multivect') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_spk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_spk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_rma_push_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 ff392aa0a..d3e35e4c2 100644 --- a/base/comm/internals/psi_sswaptran_a.F90 +++ b/base/comm/internals/psi_sswaptran_a.F90 @@ -43,7 +43,7 @@ ! 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_) +! D real(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -101,13 +101,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -149,7 +150,7 @@ contains goto 9999 end if - call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + 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) @@ -174,7 +175,8 @@ contains 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_), intent(inout) :: y(:,:) + real(psb_spk_), intent(in) :: beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -360,7 +362,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -383,7 +385,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& & psb_mpi_r_spk_,prcid(i),& @@ -413,7 +415,7 @@ contains nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -525,7 +527,7 @@ contains ! 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_) + ! D real(psb_spk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -579,12 +581,13 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -659,7 +662,8 @@ contains 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_), intent(inout) :: y(:) + real(psb_spk_), intent(in) :: beta real(psb_spk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -845,7 +849,7 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& & psb_mpi_r_spk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) @@ -868,7 +872,7 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& & psb_mpi_r_spk_,prcid(i),& @@ -896,7 +900,7 @@ contains 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_zovrl_restr.f90 b/base/comm/internals/psi_zovrl_restr.f90 index 668d1d495..a281d2e13 100644 --- a/base/comm/internals/psi_zovrl_restr.f90 +++ b/base/comm/internals/psi_zovrl_restr.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_zovrl_restr_a.f90 b/base/comm/internals/psi_zovrl_restr_a.f90 index a83470083..bffd31032 100644 --- a/base/comm/internals/psi_zovrl_restr_a.f90 +++ b/base/comm/internals/psi_zovrl_restr_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_zovrl_save.f90 b/base/comm/internals/psi_zovrl_save.f90 index 24f4011a0..c642f7898 100644 --- a/base/comm/internals/psi_zovrl_save.f90 +++ b/base/comm/internals/psi_zovrl_save.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_zovrl_save_a.f90 b/base/comm/internals/psi_zovrl_save_a.f90 index c5cb81f75..b24f82522 100644 --- a/base/comm/internals/psi_zovrl_save_a.f90 +++ b/base/comm/internals/psi_zovrl_save_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_zovrl_upd.f90 b/base/comm/internals/psi_zovrl_upd.f90 index b6a23f09e..cbe494643 100644 --- a/base/comm/internals/psi_zovrl_upd.f90 +++ b/base/comm/internals/psi_zovrl_upd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_zovrl_upd_a.f90 b/base/comm/internals/psi_zovrl_upd_a.f90 index 7bfd56b16..b879e2636 100644 --- a/base/comm/internals/psi_zovrl_upd_a.f90 +++ b/base/comm/internals/psi_zovrl_upd_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 601bc391a..5223ec5c8 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -41,7 +41,7 @@ ! 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_) +! D complex(psb_dpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -53,30 +53,22 @@ ! is scattered in the owned indices, and BETA=1. ! The first routine picks the desired exchange index list and passes it to the second. ! This version works on encapsulated vectors, and uses their methods to do GTH and SCT, -! so that special versions (i.e. GPU vectors can override them +! so that special versions (i.e. GPU vectors can override them) ! ! 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) +! swap_status - integer Swap status selector. +! It is interpreted as a communication status: +! psb_comm_status_start_ -> START phase +! psb_comm_status_wait_ -> WAIT phase +! psb_comm_status_unknown_ -> START+WAIT +! The communication scheme is selected from +! y%comm_handle%comm_type. ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. +! beta - real Choose overwrite or sum. ! y - type(psb_@x@_vect_type) The data area -! desc_a - type(psb_desc_type). The communication descriptor. +! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -90,9 +82,16 @@ submodule (psi_z_comm_v_mod) psi_z_swapdata_impl use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_ use psb_base_mod + use psb_error_mod, only: psb_get_debug_level, psb_get_debug_unit, psb_debug_ext_ + 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_, & + & psb_comm_handle_type + use psb_comm_rma_mod, only: psb_comm_rma_handle + use psb_comm_factory_mod + contains - module subroutine psi_zswapdata_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_zswapdata_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi #endif @@ -101,22 +100,24 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - class(psb_z_base_vect_type), intent(inout) :: y - complex(psb_dpk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)? + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent - ! 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 + character(len=30) :: name info = psb_success_ name = 'psi_zswapdata_vect' @@ -124,14 +125,14 @@ contains ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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 + if (.not.psb_is_asb_desc(desc_a)) then info=psb_err_invalid_cd_state_ call psb_errpush(info,name) goto 9999 @@ -143,327 +144,209 @@ contains data_ = psb_comm_halo_ end if - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then + call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') goto 9999 end if - 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 - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 end if - if (baseline) then - call psi_zswap_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_zswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') 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 - -9999 call psb_error_handler(ctxt,err_act) - - return - end subroutine psi_zswapdata_vect - - - subroutine psi_zswap_baseline_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) - implicit none - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta - class(psb_z_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info - - call psi_zswap_vidx_vect(ctxt,flag,beta,y,idx,num_neighbors,total_send,total_recv,info) - end subroutine psi_zswap_baseline_vect - - - subroutine psi_zswap_neighbor_topology_vect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,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_) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type), intent(inout) :: y - complex(psb_dpk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) - integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size - logical :: do_start, do_wait - logical, parameter :: debug = .false. - character(len=30) :: name - - - info = psb_success_ - name = 'psi_zswap_nbr_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) + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 - endif - - icomm = ctxt%get_mpic() - - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 - - call idx%sync() - - if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') - goto 9999 - end if - end if + end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - buffer_size = topology_total_send + topology_total_recv - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + 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) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') goto 9999 end if - y%communication_handle = mpi_request_null - - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) - - call y%device_wait() - - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_c_dpk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_c_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) + case(psb_comm_ineighbor_alltoallv_) + call psi_zswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') goto 9999 end if - - end if - - if (do_wait) then - - if (y%communication_handle == mpi_request_null) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_zswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,& + & total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') goto 9999 end if - - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv - - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) + case(psb_comm_rma_pull_) + call psi_zswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') goto 9999 end if - - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) - - y%communication_handle = mpi_request_null - call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) + case(psb_comm_rma_push_) + call psi_zswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') goto 9999 end if - if (debug) write(*,*) me,' nbr_vect: done' - - end if + case default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') + goto 9999 + end select call psb_erractionrestore(err_act) return 9999 call psb_error_handler(ctxt,err_act) - return - end subroutine psi_zswap_neighbor_topology_vect - + 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,info) + subroutine psi_zswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type) :: y - complex(psb_dpk_) :: beta - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! 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_) :: icomm + integer(psb_mpk_) :: np, my_rank + 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' + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti, n + logical :: do_send,do_recv + logical, parameter :: usersend=.false. + logical :: debug + character(len=20) :: name + + info = psb_success_ + name = 'psi_zswap_baseline_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif + icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' + do_send = (swap_status == psb_comm_status_start_).or.(swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_).or.(swap_status == psb_comm_status_sync_) + + total_recv_ = total_recv * n + total_send_ = total_send * n + call comm_indexes%sync() + + if (debug) write(*,*) my_rank,'Internal buffer' if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) + call psb_errpush(info,name,a_err='Unfinished communication? Something is wrong....') 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) + call y%new_buffer(ione*size(comm_indexes%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null + call psb_realloc(num_neighbors,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_) + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' Gather ' + if (debug) write(*,*) my_rank,' 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_) + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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) + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((idx_pt < 1) .or. (nesd < 0) .or. (idx_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(idx_pt,nesd,comm_indexes) pnti = pnti + nerv + nesd + 3 end do @@ -472,7 +355,7 @@ contains ! call y%device_wait() - if (debug) write(*,*) me,' isend' + if (debug) write(*,*) my_rank,' isend' ! ! Then send ! @@ -480,18 +363,18 @@ contains 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_) + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((nesd>0).and.(proc_to_comm /= my_rank)) then call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -505,8 +388,8 @@ contains end if if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -514,21 +397,21 @@ contains call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - call psb_realloc(totxch,prcid,info) + call psb_realloc(num_neighbors,prcid,info) - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' 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_) + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 (proc_to_comm /= my_rank)then if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -536,59 +419,73 @@ contains end if end if if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%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 + else if (proc_to_comm == my_rank) then if (nesd /= nerv) then write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd + & '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 - pnti = pnti + nerv + nesd + 3 + pnti = pnti + nerv + nesd + 3 end do - if (debug) write(*,*) me,' scatter' + if (debug) write(*,*) my_rank,' 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_) + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 + if ((idx_pt < 1) .or. (nerv < 0) .or. (idx_pt+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + + if (debug) write(*,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 end do + ! ! Waited for everybody, clean up ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device ! - if (debug) write(*,*) me,' wait' + if (debug) write(*,*) my_rank,' wait' call y%device_wait() - if (debug) write(*,*) me,' free buffer' + if (debug) write(*,*) my_rank,' free buffer' call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) + if (info == 0) then + if (allocated(y%comm_handle)) call y%comm_handle%free(info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if - if (debug) write(*,*) me,' done' + if (debug) write(*,*) my_rank,' done' end if @@ -598,105 +495,225 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_zswap_vidx_vect + end subroutine psi_zswap_baseline_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,info,data) + + + subroutine psi_zswap_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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 - integer(psb_ipk_), intent(in) :: flag - class(psb_z_base_multivect_type), intent(inout) :: y + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status complex(psb_dpk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data - - ! 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 + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info ! locals - 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 + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical :: debug + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_zswapdata_multivect' + name = 'psi_zswap_neighbor_topology_vect' call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,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 + icomm = ctxt%get_mpic() - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swap') + goto 9999 + end select - call desc_a%get_list_p(data_,comm_indexes,num_neighbors,total_recv,total_send,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='desc_a%get_list_p') + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') goto 9999 end if - 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 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait + call comm_indexes%sync() - 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 + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (baseline) then - call psi_zswap_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 + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + 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 + neighbor_comm_handle%comm_request = mpi_request_null + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%comm_request = mpi_request_null end if - else if (neighbor_a2av) then - call psi_zswap_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') + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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, & + & neighbor_comm_handle%comm_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%comm_request = mpi_request_null + else + if (neighbor_comm_handle%comm_request == mpi_request_null) then + write(psb_err_unit,*) my_rank, 'DBG: neighbor WAIT but comm_request is NULL; is_initialized=', & + & neighbor_comm_handle%is_initialized + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + end if + + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%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 ((1+pnti+psb_n_elem_recv_ < 1) .or. (nerv < 0) .or. & + & (1+pnti+psb_n_elem_recv_+max(0,nerv)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter metadata out of bounds') + goto 9999 + end if + if ((rcv_pt < 1) .or. (nerv < 0) .or. (rcv_pt+max(0,nerv)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline scatter combuf bounds error') + goto 9999 + end if + call y%sct(rcv_pt,nerv,comm_indexes,beta) + pnti = pnti + nerv + nesd + 3 + end do + else + ! nothing to wait/scatter + end if + + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) 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 + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait call psb_erractionrestore(err_act) return @@ -704,57 +721,44 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_zswapdata_multivect - - - subroutine psi_zswap_baseline_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) - implicit none - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta - class(psb_z_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - integer(psb_ipk_), intent(out) :: info - - call psi_zswap_vidx_multivect(ctxt,flag,beta,y,idx,num_neighbors,total_send,total_recv,info) - end subroutine psi_zswap_baseline_multivect + end subroutine psi_zswap_neighbor_topology_vect - subroutine psi_zswap_neighbor_topology_multivect(ctxt,flag,beta,y,idx, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_zswap_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_multivect_type), intent(inout) :: y - complex(psb_dpk_), intent(in) :: beta - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait - logical, parameter :: debug = .false. + logical :: debug character(len=30) :: name - + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ - name = 'psi_zswap_neighbor_topology_multivect' + name = 'psi_zswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -763,97 +767,208 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swap') + goto 9999 + end select + + if(swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status: psb_comm_status_unknown_ is not allowed in neighbor swap') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - call idx%sync() + call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_vect: building topology' - call y%neighbor_topology%init(idx%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_, name, & - & a_err='neighbor_topology_init') + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') goto 9999 end if end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv - call y%new_buffer(buffer_size, info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into combuf using baseline-style gth calls + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data (baseline layout),', topology_total_send,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(comm_indexes%v))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather metadata out of bounds') + goto 9999 + end if + if ((snd_pt < 1) .or. (nesd < 0) .or. (snd_pt+max(0,nesd)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='baseline gather combuf bounds error') + goto 9999 + end if + call y%gth(snd_pt,nesd,comm_indexes) + pnti = pnti + nerv + nesd + 3 + end do + else + neighbor_comm_handle%persistent_in_flight = .false. end if - y%communication_handle = mpi_request_null - - if (debug) write(*,*) me,' nbr_vect: gathering send data,', topology_total_send,' elems' - call y%gth(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & - & y%combuf(1:topology_total_send)) + ! Wait for device (important for GPU subclasses) call y%device_wait() - if (debug) write(*,*) me,' nbr_vect: posting MPI_Ineighbor_alltoallv' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & - & psb_mpi_c_dpk_, & - & y%combuf(topology_total_send + 1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & - & psb_mpi_c_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + ! Lazy persistent-init: build the request once, then reuse with START/WAIT. + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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, & + & neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if end if - end if + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if - if (do_wait) then + end if ! do_start - if (y%communication_handle == mpi_request_null) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/-2/)) - goto 9999 - end if + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) - if (iret /= mpi_success) then - info = psb_err_mpi_error_ - call psb_errpush(info, name, m_err=(/iret/)) - goto 9999 + if ((topology_total_send + topology_total_recv) == 0) then + ! Valid no-op exchange: nothing was posted in START and nothing to wait/scatter. + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if end if - if (debug) write(*,*) me,' nbr_vect: scattering recv data,', topology_total_recv,' elems' - call y%sct(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & - & y%combuf(topology_total_send+1:topology_total_send+topology_total_recv), & - & beta) + ! Only wait and scatter if there's data + if ((topology_total_send + topology_total_recv) > 0) then + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (baseline-style sct) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data (baseline layout),', topology_total_recv,' elems' + pnti = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + rcv_pt = 1+pnti+psb_n_elem_recv_ + if (nerv > 0) then + call y%sct(rcv_pt,nerv,comm_indexes,beta) + end if + pnti = pnti + nerv + nesd + 3 + end do + end if - y%communication_handle = mpi_request_null call y%device_wait() - call y%maybe_free_buffer(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_, name) - goto 9999 - end if - if (debug) write(*,*) me,' nbr_vect: done' + if (debug) write(*,*) my_rank,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -861,25 +976,10 @@ contains 9999 call psb_error_handler(ctxt,err_act) return - end subroutine psi_zswap_neighbor_topology_multivect - + end subroutine psi_zswap_neighbor_persistent_topology_vect - ! - ! - ! 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,info) + subroutine psi_zswap_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi #endif @@ -888,236 +988,1759 @@ contains include 'mpif.h' #endif - 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 - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n - ! 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' + + info = psb_success_ + name = 'psi_zswap_rma_pull_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,my_rank,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 - endif + end if icomm = ctxt%get_mpic() - n = y%get_ncols() + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select - 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 + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - totrcv_ = totrcv * n - totsnd_ = totsnd * n + call comm_indexes%sync() - call idx%sync() + ! START phase: build the layout once, prepare the exposed buffer, then issue RMA. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if - 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/)) + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') 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) + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + 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 - 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 + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Expose combuf once and keep the window around until the descriptor changes. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if ((recv_pos < 1) .or. (recv_count < 0) .or. (recv_pos+max(0,recv_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull local receive bounds error') + goto 9999 + end if + + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if - ! - ! Then wait for device - ! call y%device_wait() + end if - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! + call psb_erractionrestore(err_act) + return - 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) +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_zswap_rma_pull_vect + + + subroutine psi_zswap_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_zswap_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + ! START phase: identical layout handling, but the remote metadata describes the receive side. + if (do_start) then + buffer_size = total_send + total_recv + + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') 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_ + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + ! Need a larger exposed memory area: recreate the RMA window first, + ! then reallocate combuf and lazily create a new window below. + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_open = .false. 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_ + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null 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 + ! Allocate buffer with size of comm_indexes%v to include all metadata, + ! matching baseline and topology buffer layout + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(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 - - 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 + end if - ! - ! 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 ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + ! Keep the window alive across repetitions: it is created once and reused. + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. end if - if (debug) write(*,*) me,' done' - end if + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send)) + end if + call y%device_wait() - call psb_erractionrestore(err_act) - return + ! Pre-post notification receives before opening the window (prevents isend/irecv ordering issues). + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push data to each peer; after flush send a P2P notification so target knows data arrived. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = total_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if ((send_pos < 1) .or. (send_count < 0) .or. (send_pos+max(0,send_count)-1 > size(y%combuf))) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push local send bounds error') + goto 9999 + end if + + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send+1:total_send+total_recv), beta) + end if + + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_zswap_rma_push_vect + + + + ! + ! + ! Subroutine: psi_zswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_zswapdata_multivect(swap_status,beta,y,desc_a,info,data) +#ifdef PSB_MPI_MOD + use mpi +#endif + implicit none +#ifdef PSB_MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: swap_status + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + + ! communication scheme/status selectors + logical :: baseline, ineighbor_a2av, ineighbor_a2av_persistent + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, my_rank, total_send, total_recv, num_neighbors, data_, err_act + integer(psb_mpk_) :: n, total_send_, total_recv_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name + + + info = psb_success_ + name = 'psi_zswapdata_multivect' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,my_rank,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_,comm_indexes,num_neighbors,total_recv,total_send,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + if ((swap_status /= psb_comm_status_start_) .and. (swap_status /= psb_comm_status_wait_) & + & .and. (swap_status /= psb_comm_status_unknown_)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if + + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if + + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') + goto 9999 + end if + + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + baseline = .false. + ineighbor_a2av = .false. + ineighbor_a2av_persistent = .false. + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + ineighbor_a2av = .true. + case(psb_comm_persistent_ineighbor_alltoallv_) + ineighbor_a2av_persistent = .true. + case(psb_comm_rma_pull_) + call psi_zswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull swap') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_zswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,& + & y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push swap') + goto 9999 + end if + case default + baseline = .true. + end select + + if (baseline) then + call psi_zswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + else if (ineighbor_a2av) then + call psi_zswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor nonblocking swap') + goto 9999 + end if + else if (ineighbor_a2av_persistent) then + call psi_zswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor persistent swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible swap_status settings: no valid communication mode selected') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_zswapdata_multivect + + + + +subroutine psi_zswap_baseline_multivect(ctxt,swap_status,beta,y,comm_indexes, & + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& + & snd_pt, rcv_pt, pnti + logical :: do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info = psb_success_ + name = 'psi_zswap_baseline_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swap') + goto 9999 + end select + + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + total_recv_ = total_recv * n + total_send_ = total_send * n + + call comm_indexes%sync() + + if (debug) write(*,*) my_rank,'Internal buffer' + if (do_send) then + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) my_rank,'do_send start' + call y%new_buffer(total_send_+total_recv_,info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + baseline_comm_handle%comid = mpi_request_null + call psb_realloc(num_neighbors,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= my_rank)) then + if (debug) write(*,*) my_rank,'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,baseline_comm_handle%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(*,*) my_rank,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,comm_indexes) + 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(*,*) my_rank,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= my_rank)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,baseline_comm_handle%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 (do_recv) then + if (debug) write(*,*) my_rank,' do_Recv' + if (.not.allocated(baseline_comm_handle%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(num_neighbors,prcid,info) + + if (debug) write(*,*) my_rank,' wait' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= my_rank)then + if (nesd>0) then + call mpi_wait(baseline_comm_handle%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 + if (nerv>0) then + call mpi_wait(baseline_comm_handle%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 == my_rank) 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 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) my_rank,' scatter' + pnti = 1 + snd_pt = total_recv_+1 + rcv_pt = 1 + do i=1, num_neighbors + proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) + nerv = comm_indexes%v(pnti+psb_n_elem_recv_) + nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)my_rank,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,comm_indexes,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 + ! + baseline_comm_handle%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) my_rank,' wait' + call y%device_wait() + if (debug) write(*,*) my_rank,' free buffer' + call y%free_buffer(info) + if (info == 0) then + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_zswap_baseline_multivect + + + +subroutine psi_zswap_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_zswap_neighbor_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (nonblocking)' + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (buffer_size > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + ! Post non-blocking neighborhood alltoallv + 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 + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + if ((topology_total_send + topology_total_recv) > 0) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/-2/)) + goto 9999 + end if + else + neighbor_comm_handle%comm_request = mpi_request_null + end if + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Wait for the non-blocking collective to complete + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, 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 + + ! Scatter received data to local vector positions (polymorphic for GPU) + if ((topology_total_send + topology_total_recv) > 0) then + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + end if + + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null + call y%device_wait() + call y%maybe_free_buffer(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_zswap_neighbor_topology_multivect + + + +subroutine psi_zswap_neighbor_topology_multivect_persistent(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + + ! locals + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, my_rank, n + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + + info = psb_success_ + name = 'psi_zswap_neighbor_topology_multivect_persistent' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swap') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_unknown_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_unknown_) + + call comm_indexes%sync() + + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- + if (do_start) then + if(debug) write(*,*) my_rank,' nbr_vect: starting data exchange (persistent)' + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) my_rank,' nbr_vect: building topology via handle' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, & + & ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Gather send data into contiguous send buffer (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: gathering send data,', topology_total_send,' elems' + call y%gth(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(1:total_send_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + ! Wait for device (important for GPU subclasses) + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + 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 + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_r_dpk_, & + & y%combuf(total_send_ + 1), & ! recv buffer + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & 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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + end if ! do_start + + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- + if (do_wait) then + + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) > 0) then + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + + ! Wait for the persistent collective to complete + if (debug) write(*,*) my_rank,' nbr_vect: waiting on persistent MPI request' + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Scatter received data to local vector positions (polymorphic for GPU) + if (debug) write(*,*) my_rank,' nbr_vect: scattering recv data,', topology_total_recv,' elems' + call y%sct(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(total_send_+1:total_send_+total_recv_), & + & beta) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + if (debug) write(*,*) my_rank,' nbr_vect: done' + + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return +end subroutine psi_zswap_neighbor_topology_multivect_persistent + + + subroutine psi_zswap_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_zswap_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for pull mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA pull init_memory_buffer_layout failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pull data from each peer with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter received data into Y. + if (do_wait) then + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_zswap_rma_pull_multivect + + + subroutine psi_zswap_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, total_send_, total_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, memory_buffer_layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_zswap_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + total_send_ = total_send * n + total_recv_ = total_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for push mode') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_send_ + total_recv_ + memory_buffer_layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= total_send) .or. & + & (rma_handle%layout_recv /= total_recv) + + if (memory_buffer_layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA put rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA put ini_memory_buffer_layout') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (total_send > 0) then + call y%gth(int(total_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1) * n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (total_recv > 0) then + call y%sct(int(total_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(total_send_+1:total_send_+total_recv_), beta) + end if + call y%device_wait() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_zswap_rma_push_multivect -9999 call psb_error_handler(ctxt,err_act) - 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 471eecd55..d76ff7425 100644 --- a/base/comm/internals/psi_zswapdata_a.F90 +++ b/base/comm/internals/psi_zswapdata_a.F90 @@ -39,7 +39,7 @@ ! 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_) +! D complex(psb_dpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -70,10 +70,10 @@ ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:,:) - complex The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do +! 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 @@ -97,13 +97,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -165,12 +166,13 @@ complex(psb_dpk_), target :: work(:) #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n 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 + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -293,8 +295,8 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_dpk_,icomm,iret) + & 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/)) @@ -348,9 +350,9 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + n*nerv @@ -370,15 +372,15 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag + 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_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret) else call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret) end if @@ -401,7 +403,7 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -510,7 +512,7 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf ! 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_) + ! D complex(psb_dpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -541,10 +543,10 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf ! ! ! n - integer Number of columns in Y - ! beta - complex Choose overwrite or sum. - ! y(:) - complex The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - complex Buffer space. If not sufficient, will do + ! 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 @@ -565,12 +567,13 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + integer(psb_ipk_), intent(in) :: flag + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -648,7 +651,8 @@ 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_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -775,8 +779,8 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_dpk_,icomm,iret) + & 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/)) @@ -830,9 +834,9 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag, icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + nerv @@ -852,16 +856,16 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag + 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_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret) else call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret) end if @@ -882,7 +886,7 @@ complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nerv>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index 308d19be8..d262b5c2d 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -43,7 +43,7 @@ ! 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_) +! D complex(psb_dpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -59,12 +59,12 @@ ! ! ! Arguments: -! flag - integer Choose the algorithm for data exchange: +! swap_status - 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 +! swap_mpi = iand(swap_status,psb_swap_mpi_) /= 0 +! swap_sync = iand(swap_status,psb_swap_sync_) /= 0 +! swap_send = iand(swap_status,psb_swap_send_) /= 0 +! swap_recv = iand(swap_status,psb_swap_recv_) /= 0 ! if (swap_mpi): use underlying MPI_ALLTOALLV. ! if (swap_sync): use PSB_SND and PSB_RCV in ! synchronized pairs @@ -77,9 +77,10 @@ ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y - type(psb_z_vect_type) The data area +! beta - real Choose overwrite or sum. +! y - type(psb_d_vect_type) The data area ! desc_a - type(psb_desc_type). The communication descriptor. +! our own internal allocation. ! info - integer. return code. ! data - integer which list is to be used to exchange data ! default psb_comm_halo_ @@ -91,8 +92,9 @@ ! submodule (psi_z_comm_v_mod) psi_z_swaptran_impl use psb_base_mod + use psb_comm_factory_mod contains - module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,info,data) + module subroutine psi_zswaptran_vect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -102,24 +104,19 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta - class(psb_z_base_vect_type), intent(inout) :: y - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ - 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 - logical :: baseline, neighbor_a2av - + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, err_act, data_ + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=20) :: name info = psb_success_ name = 'psi_zswaptran_vect' @@ -152,39 +149,64 @@ contains goto 9999 end if - 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 + if( (swap_status /= psb_comm_status_start_).and.(swap_status /= psb_comm_status_wait_)& + & .and.(swap_status /= psb_comm_status_sync_) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid swap_status swap_status') + goto 9999 + end if - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, 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 + end if + end if - 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') + ! Set the normalized swap status on the comm handle + call y%comm_handle%set_swap_status(swap_status, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if - if (baseline) then - call psi_ztran_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_ztran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + call psb_errpush(info,name,a_err='neighbor a2av tran') goto 9999 end if - else if (neighbor_a2av) then - call psi_ztran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_ztran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + call psb_errpush(info,name,a_err='persistent neighbor tran') 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 + case(psb_comm_rma_pull_) + call psi_ztran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_ztran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_ztran_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -194,8 +216,21 @@ contains return end subroutine psi_zswaptran_vect - subroutine psi_ztran_baseline_vect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + ! + ! + ! Subroutine: psi_ztran_baseline_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_baseline_vect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -206,11 +241,12 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_vect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals @@ -218,7 +254,8 @@ contains 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_,& + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -236,23 +273,29 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - totrcv_ = total_recv * n - totsnd_ = total_send * n + total_recv_ = total_recv * n + total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -262,17 +305,17 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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_ @@ -281,7 +324,7 @@ contains 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 end do @@ -293,13 +336,13 @@ contains pnti = 1 snd_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + call y%gth(idx_pt,nerv,idx) pnti = pnti + nerv + nesd + 3 end do @@ -317,18 +360,18 @@ contains pnti = 1 snd_pt = 1 rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -343,7 +386,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -355,17 +398,17 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -373,7 +416,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -396,22 +439,22 @@ contains snd_pt = 1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -420,7 +463,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -439,28 +484,32 @@ contains end subroutine psi_ztran_baseline_vect - subroutine psi_ztran_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + + + subroutine psi_ztran_neighbor_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_vect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. @@ -470,7 +519,7 @@ contains info = psb_success_ name = 'psi_ztran_neighbor_topology_vect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -479,17 +528,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_vect: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -497,8 +559,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -506,70 +572,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_vect: gathering (recv) data,', topology_total_recv,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_c_dpk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & & psb_mpi_c_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_vect: scattering (send) data,', topology_total_send,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_vect: done' + if (debug) write(*,*) me,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -581,7 +658,18 @@ contains - module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,info,data) + + ! + ! + ! + ! + ! Subroutine: psi_zswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_zswaptran_multivect(swap_status,beta,y,desc_a,info,data) #ifdef PSB_MPI_MOD use mpi @@ -591,8 +679,8 @@ contains include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_multivect_type), intent(inout) :: y type(psb_desc_type),target :: desc_a integer(psb_ipk_), intent(out) :: info @@ -605,9 +693,8 @@ contains 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 - logical :: baseline, neighbor_a2av + integer(psb_ipk_) :: setflag + info = psb_success_ name = 'psi_zswaptran_multivect' @@ -617,7 +704,7 @@ contains icomm = ctxt%get_mpic() call psb_info(ctxt,me,np) if (np == -1) then - info=psb_err_context_error_ + info = psb_err_context_error_ call psb_errpush(info,name) goto 9999 endif @@ -639,40 +726,74 @@ contains call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') goto 9999 end if - 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 + setflag = swap_status + if (swap_status == psb_swap_start_) then + setflag = psb_comm_status_start_ + else if (swap_status == psb_swap_wait_) then + setflag = psb_comm_status_wait_ + else if ((iand(swap_status, psb_swap_send_) /= 0) .or. (iand(swap_status, psb_swap_recv_) /= 0) .or. & + & (iand(swap_status, psb_swap_mpi_) /= 0) .or. (iand(swap_status, psb_swap_sync_) /= 0)) then + setflag = psb_comm_status_sync_ + end if - if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + if ((setflag /= psb_comm_status_start_) .and. (setflag /= psb_comm_status_wait_) .and. & + & (setflag /= psb_comm_status_sync_)) then info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') + call psb_errpush(info,name,a_err='Invalid swap_status') goto 9999 end if - if (baseline) then - call psi_ztran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (.not. allocated(y%comm_handle)) then + call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 end if - else if (neighbor_a2av) then - call psi_ztran_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') + end if + + call y%comm_handle%set_swap_status(setflag, info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='set_swap_status') goto 9999 end if + select case(y%comm_handle%comm_type) + case(psb_comm_ineighbor_alltoallv_) + call psi_ztran_neighbor_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av tran') + goto 9999 + end if + case(psb_comm_persistent_ineighbor_alltoallv_) + call psi_ztran_neighbor_persistent_topology_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='persistent neighbor tran') + goto 9999 + end if + case(psb_comm_rma_pull_) + call psi_ztran_rma_pull_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma pull tran') + goto 9999 + end if + case(psb_comm_rma_push_) + call psi_ztran_rma_push_multivect(ctxt,setflag,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='rma push tran') + goto 9999 + end if + case default + call psi_ztran_baseline_multivect(ctxt,setflag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline tran') + goto 9999 + end if + end select call psb_erractionrestore(err_act) return @@ -682,9 +803,8 @@ contains return end subroutine psi_zswaptran_multivect - - module subroutine psi_ztran_baseline_multivect(ctxt,flag,beta,y,comm_indexes,& - & num_neighbors,total_send,total_recv,info) + subroutine psi_ztran_baseline_multivect(ctxt,swap_status,beta,y,idx,& + & num_neighbors,total_send,total_recv,comm_handle,info) #ifdef PSB_MPI_MOD use mpi @@ -695,19 +815,21 @@ contains #endif type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta - class(psb_z_base_multivect_type), intent(inout) :: y - class(psb_i_base_vect_type), intent(inout) :: comm_indexes - integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv + integer(psb_ipk_), intent(in) :: swap_status integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle ! 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_,& + type(psb_comm_baseline_handle), pointer :: baseline_comm_handle + integer(psb_ipk_) :: err_act, i, idx_pt, total_send_, total_recv_,& & snd_pt, rcv_pt, pnti logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv @@ -715,7 +837,7 @@ contains character(len=20) :: name info = psb_success_ - name = 'psi_ztran_baseline_multivect' + name = 'psi_ztran_vidx_multivect' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then @@ -725,24 +847,30 @@ contains endif icomm = ctxt%get_mpic() + baseline_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_baseline_handle) + baseline_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected baseline comm_handle in baseline multivect swaptran') + goto 9999 + end select + 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 + do_send = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_recv = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) - totrcv_ = total_recv * n - totsnd_ = total_send * n + total_recv_ = total_recv * n + total_send_ = total_send * n - call comm_indexes%sync() + 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 + if (allocated(baseline_comm_handle%comid)) then + if (any(baseline_comm_handle%comid /= mpi_request_null)) then ! ! Unfinished communication? Something is wrong.... ! @@ -752,25 +880,25 @@ contains end if end if if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(comm_indexes%v),info) - call y%new_comid(num_neighbors,info) - y%comid = mpi_request_null + call y%new_buffer(ione*size(idx%v),info) + call psb_realloc(num_neighbors,2_psb_ipk_,baseline_comm_handle%comid,info) + baseline_comm_handle%comid = mpi_request_null call psb_realloc(num_neighbors,prcid,info) ! First I post all the non blocking receives pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag, icomm,baseline_comm_handle%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv snd_pt = snd_pt + n*nesd @@ -782,13 +910,13 @@ contains ! Then gather for sending. ! pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes) + 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 @@ -805,19 +933,19 @@ contains ! pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + & p2ptag,icomm,baseline_comm_handle%comid(i,1),iret) end if if(iret /= mpi_success) then @@ -833,7 +961,7 @@ contains if (do_recv) then if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then + if (.not.allocated(baseline_comm_handle%comid)) then ! ! No matching send? Something is wrong.... ! @@ -845,16 +973,16 @@ contains if (debug) write(*,*) me,' wait' pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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) + call mpi_wait(baseline_comm_handle%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -862,7 +990,7 @@ contains end if end if if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) + call mpi_wait(baseline_comm_handle%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then info=psb_err_mpi_error_ call psb_errpush(info,name,m_err=(/iret/)) @@ -884,17 +1012,17 @@ contains if (debug) write(*,*) me,' scatter' pnti = 1 - snd_pt = totrcv_+1 + snd_pt = total_recv_+1 rcv_pt = 1 do i=1, num_neighbors - proc_to_comm = comm_indexes%v(pnti+psb_proc_id_) - nerv = comm_indexes%v(pnti+psb_n_elem_recv_) - nesd = comm_indexes%v(pnti+nerv+psb_n_elem_send_) + 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,comm_indexes,beta) + 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 @@ -904,7 +1032,7 @@ contains ! ! Waited for com, cleanup comid ! - y%comid = mpi_request_null + baseline_comm_handle%comid = mpi_request_null ! ! Then wait for device @@ -913,7 +1041,9 @@ contains 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 + if (allocated(y%comm_handle)) call psb_comm_free(y%comm_handle, info) + end if if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 @@ -932,30 +1062,30 @@ contains end subroutine psi_ztran_baseline_multivect - - - subroutine psi_ztran_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes, & - & num_neighbors,total_send,total_recv,info) + subroutine psi_ztran_neighbor_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_multivect_type), intent(inout) :: y class(psb_i_base_vect_type), intent(inout) :: comm_indexes integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle integer(psb_ipk_), intent(out) :: info ! locals integer(psb_mpk_) :: icomm integer(psb_mpk_) :: np, me integer(psb_mpk_) :: iret, p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size logical :: do_start, do_wait logical, parameter :: debug = .false. @@ -965,7 +1095,7 @@ contains info = psb_success_ name = 'psi_ztran_neighbor_topology_multivect' call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) + call psb_info(ctxt,me,np) if (np == -1) then info=psb_err_context_error_ call psb_errpush(info,name) @@ -974,17 +1104,30 @@ contains icomm = ctxt%get_mpic() - do_start = iand(flag,psb_swap_start_) /= 0 - do_wait = iand(flag,psb_swap_wait_) /= 0 + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in neighbor multivect swaptran') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) call comm_indexes%sync() + ! --------------------------------------------------------- + ! START phase: build topology (if needed), gather, post MPI + ! --------------------------------------------------------- if (do_start) then - if(debug) write(*,*) me,' nbr_tran_vect: starting data exchange' - if (.not. y%neighbor_topology%is_initialized) then - if (debug) write(*,*) me,' nbr_tran_vect: building topology' - call y%neighbor_topology%init(comm_indexes%v, num_neighbors, total_send, total_recv, & - & ctxt, icomm, info) + if(debug) write(*,*) me,' nbr_vect: starting data exchange' + ! Lazy initialization: build the topology on first call + if (.not. neighbor_comm_handle%is_initialized) then + if (debug) write(*,*) me,' nbr_vect: building topology' + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, & & a_err='neighbor_topology_init') @@ -992,8 +1135,12 @@ contains end if end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + ! Buffer layout: + ! combuf(1 : total_send) = send area + ! combuf(total_send+1 : total_send+total_recv) = recv area buffer_size = topology_total_send + topology_total_recv call y%new_buffer(buffer_size, info) @@ -1001,70 +1148,81 @@ contains call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - y%communication_handle = mpi_request_null + neighbor_comm_handle%comm_request = mpi_request_null - if (debug) write(*,*) me,' nbr_tran_vect: gathering (recv) data,', topology_total_recv,' elems' - call y%gth(int(topology_total_recv,psb_mpk_), & - & y%neighbor_topology%recv_indexes, & + ! For transpose exchange: gather recv area first (we will send "recv" data) + if (debug) write(*,*) me,' nbr_tran_vect: gathering recv data,', topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & & y%combuf(1:topology_total_recv)) - call y%device_wait() + ! Wait for device (important for GPU subclasses) + call y%device_wait() - if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' - call mpi_ineighbor_alltoallv( & - & y%combuf(1), & - & y%neighbor_topology%recv_counts, & - & y%neighbor_topology%recv_displs, & + ! Post non-blocking neighborhood alltoallv swapping send/recv arrays + if (debug) write(*,*) me,' nbr_tran_vect: posting MPI_Ineighbor_alltoallv (swapped)' + call mpi_ineighbor_alltoallv( & + & y%combuf(1), & ! send buffer (recv_indexes gathered) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & & psb_mpi_c_dpk_, & - & y%combuf(topology_total_recv + 1), & - & y%neighbor_topology%send_counts, & - & y%neighbor_topology%send_displs, & + & y%combuf(topology_total_recv + 1), & ! recv buffer (will contain send_indexes data) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & & psb_mpi_c_dpk_, & - & y%neighbor_topology%graph_comm, & - & y%communication_handle, iret) + & neighbor_comm_handle%graph_comm, & + & neighbor_comm_handle%comm_request, 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 ! do_start + ! --------------------------------------------------------- + ! WAIT phase: complete MPI, scatter received data + ! --------------------------------------------------------- if (do_wait) then - if (y%communication_handle == mpi_request_null) then + if (neighbor_comm_handle%comm_request == mpi_request_null) then + ! No matching start? Something is wrong info = psb_err_mpi_error_ call psb_errpush(info, name, m_err=(/-2/)) goto 9999 end if - topology_total_send = y%neighbor_topology%total_send - topology_total_recv = y%neighbor_topology%total_recv + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv - if (debug) write(*,*) me,' nbr_tran_vect: waiting on MPI request' - call mpi_wait(y%communication_handle, p2pstat, iret) + ! Wait for the non-blocking collective to complete + if (debug) write(*,*) me,' nbr_vect: waiting on MPI request' + call mpi_wait(neighbor_comm_handle%comm_request, p2pstat, iret) 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,' nbr_tran_vect: scattering (send) data,', topology_total_send,' elems' - call y%sct(int(topology_total_send,psb_mpk_), & - & y%neighbor_topology%send_indexes, & + ! For transpose exchange: scatter the data that correspond to peers' send area + if (debug) write(*,*) me,' nbr_tran_vect: scattering send-index data,', topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & & beta) - y%communication_handle = mpi_request_null + + ! Clean up + neighbor_comm_handle%comm_request = mpi_request_null call y%device_wait() call y%maybe_free_buffer(info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - if (debug) write(*,*) me,' nbr_tran_vect: done' + if (debug) write(*,*) me,' nbr_vect: done' - end if + end if ! do_wait call psb_erractionrestore(err_act) return @@ -1074,4 +1232,1336 @@ contains return end subroutine psi_ztran_neighbor_topology_multivect + + + subroutine psi_ztran_neighbor_persistent_topology_vect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_ztran_neighbor_persistent_topology_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + buffer_size = topology_total_send + topology_total_recv + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes (we "send" recv data) + if (debug) write(*,*) my_rank,' tran_persistent_vect: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:topology_total_recv)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv counts in alltoallv_init + ! send = recv_indexes data with recv_counts/displs + ! recv = into send_indexes area with send_counts/displs + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs, & + & psb_mpi_c_dpk_, & + & y%combuf(topology_total_recv + 1), & + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs, & + & psb_mpi_c_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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_vect: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(topology_total_recv+1:topology_total_recv+topology_total_send), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_neighbor_persistent_topology_vect + + + subroutine psi_ztran_rma_pull_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + ! Effective sizes for transpose: + ! eff_send = total_recv (we expose recv_indexes data) + ! eff_recv = total_send (we GET into the send_indexes area) + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ztran_rma_pull_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_rma_pull_vect + + + subroutine psi_ztran_rma_push_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ztran_rma_push_vect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + eff_send = total_recv + eff_recv = total_send + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = eff_send + eff_recv + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push rank cache allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push init_memory_buffer_layout_tran failure') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < size(comm_indexes%v)) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(ione*size(comm_indexes%v), info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + ! Transpose: gather recv_indexes data into combuf(1:eff_send) + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:eff_send)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + ! Push our recv_indexes data to each peer's send_indexes area; notify after flush. + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx) + 1 + recv_pos = eff_send + rma_handle%peer_recv_displs(neighbor_idx) + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int(remote_base - 1, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count-1) = y%combuf(send_pos:send_pos+send_count-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + ! Transpose: scatter to send_indexes (peer_recv_indexes in tran init = actual send_indexes) + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, y%combuf(eff_send+1:eff_send+eff_recv), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_rma_push_vect + + + subroutine psi_ztran_neighbor_persistent_topology_multivect(ctxt,swap_status,beta,y,comm_indexes,& + & num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: icomm, np, my_rank, iret, n + integer(psb_mpk_) :: p2pstat(mpi_status_size) + type(psb_comm_neighbor_handle), pointer :: neighbor_comm_handle + integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size + integer(psb_mpk_) :: total_send_, total_recv_ + logical :: do_start, do_wait + logical, parameter :: debug = .false. + character(len=30) :: name + + info = psb_success_ + name = 'psi_ztran_neighbor_persistent_topology_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,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() + + neighbor_comm_handle => null() + select type(ch => comm_handle) + type is(psb_comm_neighbor_handle) + neighbor_comm_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected neighbor comm_handle in persistent neighbor multivect swaptran') + goto 9999 + end select + + if (swap_status == psb_comm_status_unknown_) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='psb_comm_status_unknown_ not allowed in persistent neighbor multivect swaptran') + goto 9999 + end if + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + if (neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Invalid START: persistent neighbor request already in flight') + goto 9999 + end if + if (.not. neighbor_comm_handle%is_initialized) then + call neighbor_comm_handle%topology_init(comm_indexes%v, num_neighbors, total_send, total_recv, ctxt, icomm, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_, name, a_err='neighbor_topology_init') + goto 9999 + end if + end if + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + buffer_size = total_send_ + total_recv_ + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, 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 + 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) + end if + neighbor_comm_handle%persistent_request = mpi_request_null + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_in_flight = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + call y%new_buffer(buffer_size, info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_, name) + goto 9999 + end if + end if + end if + neighbor_comm_handle%comm_request = mpi_request_null + + if (buffer_size > 0) then + ! Transpose: gather from recv_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: gathering recv data,',topology_total_recv,' elems' + call y%gth(int(topology_total_recv,psb_mpk_), & + & neighbor_comm_handle%recv_indexes, & + & y%combuf(1:total_recv_)) + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + + call y%device_wait() + + if (.not. neighbor_comm_handle%persistent_request_ready) then + if (buffer_size > 0) then + ! Transpose: swap send/recv in alltoallv_init + call mpi_neighbor_alltoallv_init( & + & y%combuf(1), & + & n*neighbor_comm_handle%recv_counts, & + & n*neighbor_comm_handle%recv_displs, & + & psb_mpi_c_dpk_, & + & y%combuf(total_recv_ + 1), & + & n*neighbor_comm_handle%send_counts, & + & n*neighbor_comm_handle%send_displs, & + & psb_mpi_c_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_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_request_ready = .true. + neighbor_comm_handle%persistent_buffer_size = buffer_size + else + neighbor_comm_handle%persistent_request_ready = .false. + neighbor_comm_handle%persistent_buffer_size = 0 + end if + end if + + if (buffer_size > 0) then + call mpi_start(neighbor_comm_handle%persistent_request, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .true. + else + neighbor_comm_handle%persistent_in_flight = .false. + end if + end if ! do_start + + if (do_wait) then + topology_total_send = neighbor_comm_handle%total_send + topology_total_recv = neighbor_comm_handle%total_recv + total_send_ = topology_total_send * n + total_recv_ = topology_total_recv * n + + if ((topology_total_send + topology_total_recv) == 0) then + neighbor_comm_handle%persistent_in_flight = .false. + else + if (.not. neighbor_comm_handle%persistent_in_flight) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, a_err='Invalid WAIT: no persistent neighbor request in flight') + goto 9999 + end if + end if + + if ((topology_total_send + topology_total_recv) > 0) then + call mpi_wait(neighbor_comm_handle%persistent_request, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info, name, m_err=(/iret/)) + goto 9999 + end if + neighbor_comm_handle%persistent_in_flight = .false. + + ! Transpose: scatter to send_indexes + if (debug) write(*,*) my_rank,' tran_persistent_mv: scattering to send_indexes,',topology_total_send,' elems' + call y%sct(int(topology_total_send,psb_mpk_), & + & neighbor_comm_handle%send_indexes, & + & y%combuf(total_recv_+1:total_recv_+total_send_), & + & beta) + end if + + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_neighbor_persistent_topology_multivect + + + subroutine psi_ztran_rma_pull_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ztran_rma_pull_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran pull multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran pull multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran pull multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pull from each peer's recv_indexes area with per-neighbor passive lock (neighbor-only sync). + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_send_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran pull multivect') + goto 9999 + end if + if (recv_count > 0) then + call mpi_win_lock(MPI_LOCK_SHARED, prc_rank, 0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_get(y%combuf(recv_pos), recv_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, recv_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_win_unlock(prc_rank, rma_handle%win, 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran pull multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: GETs already complete (per-neighbor unlock in START); scatter into send_indexes. + if (do_wait) then + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_rma_pull_multivect + + + subroutine psi_ztran_rma_push_multivect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,comm_handle,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_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_multivect_type), intent(inout) :: y + class(psb_i_base_vect_type), intent(inout) :: comm_indexes + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + class(psb_comm_handle_type), intent(inout) :: comm_handle + integer(psb_ipk_), intent(out) :: info + + integer(psb_mpk_) :: np, my_rank, iret, element_bytes, icomm, n + integer(psb_mpk_) :: proc_to_comm, prc_rank, recv_count, send_count, send_pos, recv_pos, list_pos + integer(psb_mpk_) :: remote_base + integer(kind=MPI_ADDRESS_KIND) :: remote_disp, exposed_bytes + integer(psb_ipk_) :: err_act, neighbor_idx, buffer_size, eff_send, eff_recv, total_eff_send_, total_eff_recv_ + integer(psb_ipk_), allocatable :: peer_mpi_rank(:) + integer(psb_mpk_), parameter :: rma_push_notify_tag = 914_psb_mpk_ + logical :: do_start, do_wait, layout_rebuild_needed + type(psb_comm_rma_handle), pointer :: rma_handle + character(len=30) :: name + + info = psb_success_ + name = 'psi_ztran_rma_push_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,my_rank,np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + end if + icomm = ctxt%get_mpic() + n = y%get_ncols() + eff_send = total_recv + eff_recv = total_send + total_eff_send_ = eff_send * n + total_eff_recv_ = eff_recv * n + + select type(ch => comm_handle) + type is(psb_comm_rma_handle) + rma_handle => ch + class default + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Expected RMA comm_handle for tran push multivect') + goto 9999 + end select + + do_start = (swap_status == psb_comm_status_start_) .or. (swap_status == psb_comm_status_sync_) + do_wait = (swap_status == psb_comm_status_wait_) .or. (swap_status == psb_comm_status_sync_) + + call comm_indexes%sync() + + if (do_start) then + buffer_size = total_eff_send_ + total_eff_recv_ + layout_rebuild_needed = (.not. rma_handle%layout_ready) .or. & + & (rma_handle%layout_nnbr /= num_neighbors) .or. & + & (rma_handle%layout_send /= eff_send) .or. & + & (rma_handle%layout_recv /= eff_recv) + + if (layout_rebuild_needed) then + if (allocated(peer_mpi_rank)) deallocate(peer_mpi_rank) + if (num_neighbors > 0) then + allocate(peer_mpi_rank(num_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name,a_err='RMA tran push multivect rank allocation') + goto 9999 + end if + end if + list_pos = 1 + do neighbor_idx = 1, num_neighbors + proc_to_comm = comm_indexes%v(list_pos+psb_proc_id_) + peer_mpi_rank(neighbor_idx) = psb_get_mpi_rank(ctxt,proc_to_comm) + recv_count = comm_indexes%v(list_pos+psb_n_elem_recv_) + send_count = comm_indexes%v(list_pos+recv_count+psb_n_elem_send_) + list_pos = list_pos + recv_count + send_count + 3 + end do + call rma_handle%init_memory_buffer_layout_tran(info, comm_indexes%v, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='RMA tran push multivect init_memory_buffer_layout_tran') + goto 9999 + end if + end if + + if (buffer_size > 0) then + if (.not. allocated(y%combuf)) then + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + else if (size(y%combuf) < buffer_size) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + rma_handle%window_open = .false. + end if + if (rma_handle%window_ready) then + call mpi_win_free(rma_handle%win, iret) + rma_handle%window_ready = .false. + rma_handle%win = mpi_win_null + end if + call y%new_buffer(buffer_size, info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + end if + + if ((buffer_size > 0).and.(.not. rma_handle%window_ready)) then + element_bytes = storage_size(y%combuf(1))/8 + exposed_bytes = int(size(y%combuf),kind=MPI_ADDRESS_KIND) * int(element_bytes,kind=MPI_ADDRESS_KIND) + call mpi_win_create(y%combuf, exposed_bytes, element_bytes, & + & mpi_info_null, ctxt%get_mpic(), rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_ready = .true. + end if + + if (buffer_size > 0) then + if (eff_send > 0) then + call y%gth(int(eff_send,psb_mpk_), rma_handle%peer_send_indexes, y%combuf(1:total_eff_send_)) + end if + call y%device_wait() + + ! Pre-post notification receives before opening the window. + if (num_neighbors > 0) then + rma_handle%notify_recv_reqs(1:num_neighbors) = MPI_REQUEST_NULL + rma_handle%notify_send_reqs(1:num_neighbors) = MPI_REQUEST_NULL + end if + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + call mpi_irecv(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_recv_reqs(neighbor_idx), 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 do + + call mpi_win_lock_all(0, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .true. + + do neighbor_idx=1, num_neighbors + proc_to_comm = rma_handle%peer_proc(neighbor_idx) + send_count = rma_handle%peer_send_counts(neighbor_idx) + recv_count = rma_handle%peer_recv_counts(neighbor_idx) + prc_rank = rma_handle%peer_mpi_rank(neighbor_idx) + send_pos = rma_handle%peer_send_displs(neighbor_idx)*n + 1 + recv_pos = total_eff_send_ + rma_handle%peer_recv_displs(neighbor_idx)*n + 1 + + if (proc_to_comm /= my_rank) then + remote_base = rma_handle%peer_remote_recv_displs(neighbor_idx) + if (remote_base < 1) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid remote metadata in RMA tran push multivect') + goto 9999 + end if + if (send_count > 0) then + remote_disp = int((remote_base - 1)*n, kind=MPI_ADDRESS_KIND) + call mpi_put(y%combuf(send_pos), send_count*n, psb_mpi_r_dpk_, prc_rank, remote_disp, send_count*n, psb_mpi_r_dpk_, & + & rma_handle%win, 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 + call mpi_win_flush(prc_rank, rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_isend(rma_handle%notify_buf(neighbor_idx), 1, psb_mpi_mpk_, prc_rank, & + & rma_push_notify_tag, icomm, rma_handle%notify_send_reqs(neighbor_idx), 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 (send_count /= recv_count) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='RMA tran push multivect self-copy mismatch') + goto 9999 + end if + y%combuf(recv_pos:recv_pos+recv_count*n-1) = y%combuf(send_pos:send_pos+send_count*n-1) + end if + end do + end if + end if ! do_start + + ! WAIT phase: close epoch, wait for P2P notifications, then scatter into send_indexes. + if (do_wait) then + if (rma_handle%window_open) then + call mpi_win_unlock_all(rma_handle%win, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rma_handle%window_open = .false. + end if + if (num_neighbors > 0) then + call mpi_waitall(num_neighbors, rma_handle%notify_recv_reqs, MPI_STATUSES_IGNORE, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + call mpi_waitall(num_neighbors, rma_handle%notify_send_reqs, MPI_STATUSES_IGNORE, 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 + if (eff_recv > 0) then + call y%sct(int(eff_recv,psb_mpk_), rma_handle%peer_recv_indexes, & + & y%combuf(total_eff_send_+1:total_eff_send_+total_eff_recv_), beta) + end if + call y%device_wait() + end if ! do_wait + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_rma_push_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 2ea4d2b86..1c06bef10 100644 --- a/base/comm/internals/psi_zswaptran_a.F90 +++ b/base/comm/internals/psi_zswaptran_a.F90 @@ -30,7 +30,7 @@ ! ! ! -! File: psi_zswaptran.F90 +! File: psi_zswaptran_a.F90 ! ! Subroutine: psi_zswaptranm ! Implements the data exchange among processes. This is similar to Xswapdata, but @@ -43,7 +43,7 @@ ! 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_) +! D complex(psb_dpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -74,10 +74,10 @@ ! ! ! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:,:) - complex The data area +! beta - real Choose overwrite or sum. +! y(:,:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do +! 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 @@ -101,13 +101,14 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + integer(psb_mpk_), intent(in) :: n + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) + type(psb_desc_type),target :: desc_a + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -149,7 +150,7 @@ contains goto 9999 end if - call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + 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) @@ -174,7 +175,8 @@ contains 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_), intent(inout) :: y(:,:) + complex(psb_dpk_), intent(in) :: beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -305,8 +307,8 @@ contains ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) + & 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/)) @@ -360,9 +362,9 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + n*nerv @@ -383,14 +385,14 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret) else call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,iret) end if @@ -413,7 +415,7 @@ contains nerv = idx(pnti+psb_n_elem_recv_) nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) @@ -525,7 +527,7 @@ contains ! 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_) + ! D complex(psb_dpk_) ! C complex(psb_spk_) ! Z complex(psb_dpk_) ! Basically the operation is as follows: on each process, we identify @@ -556,10 +558,10 @@ contains ! ! ! n - integer Number of columns in Y - ! beta - complex Choose overwrite or sum. - ! y(:) - complex The data area + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area ! desc_a - type(psb_desc_type). The communication descriptor. - ! work(:) - complex Buffer space. If not sufficient, will do + ! 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 @@ -579,12 +581,13 @@ contains 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 + integer(psb_ipk_), intent(in) :: flag + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) + type(psb_desc_type),target :: desc_a + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data ! locals type(psb_ctxt_type) :: ctxt @@ -659,7 +662,8 @@ contains 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_), intent(inout) :: y(:) + complex(psb_dpk_), intent(in) :: beta complex(psb_dpk_), target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv @@ -791,8 +795,8 @@ contains ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) + & 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/)) @@ -845,9 +849,9 @@ contains 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 + p2ptag = psb_double_swap_tag call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag,icomm,rvhd(i),iret) end if rcv_pt = rcv_pt + nerv @@ -868,14 +872,14 @@ contains nesd = idx(pnti+nerv+psb_n_elem_send_) if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag + p2ptag = psb_double_swap_tag if (usersend) then call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag, icomm,iret) else call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& + & psb_mpi_r_dpk_,prcid(i),& & p2ptag, icomm,iret) end if @@ -896,7 +900,7 @@ contains 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 + p2ptag = psb_double_swap_tag if ((proc_to_comm /= me).and.(nesd>0)) then call mpi_wait(rvhd(i),p2pstat,iret) diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index bc5302f56..443d17290 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_cgather_a.f90 b/base/comm/psb_cgather_a.f90 index ac2e66e4a..ee1420d70 100644 --- a/base/comm/psb_cgather_a.f90 +++ b/base/comm/psb_cgather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_cgatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index 4972afdd4..ba51ab33c 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -51,35 +51,35 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_chalo_vect(x,desc_a,info,tran,mode,data) +subroutine psb_chalo_vect(x,desc_a,info,tran,mode,data) use psb_base_mod, psb_protect_name => psb_chalo_vect use psi_mod implicit none - type(psb_c_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_c_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & - & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name = 'psb_chalo_vect' + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + & nrow, ncol, lldx, imode,data_ + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name = 'psb_chalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ + info = psb_err_internal_error_ goto 9999 end if - ctxt=desc_a%get_context() + ctxt = desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -116,7 +116,7 @@ subroutine psb_chalo_vect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if ((info == 0).and.(lldx psb_chalo_multivect use psi_mod implicit none - type(psb_c_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_c_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_chalo_multivect' + name = 'psb_chalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -238,7 +239,7 @@ subroutine psb_chalo_multivect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if (lldx < ncol) call x%reall(ncol,x%get_ncols(),info) @@ -261,7 +262,7 @@ subroutine psb_chalo_multivect(x,desc_a,info,tran,mode,data) end if if (info /= psb_success_) then - ch_err = 'PSI_swapdata' + ch_err='PSI_swapdata' call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if diff --git a/base/comm/psb_chalo_a.f90 b/base/comm/psb_chalo_a.f90 index d2e3480cb..2a0441071 100644 --- a/base/comm/psb_chalo_a.f90 +++ b/base/comm/psb_chalo_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -! File: psb_chalo_a.f90 +! File: psb_chalo.f90 ! ! Subroutine: psb_chalom ! This subroutine performs the exchange of the halo elements in a @@ -52,7 +52,7 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) +subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_chalom use psi_mod implicit none @@ -217,7 +217,7 @@ end subroutine psb_chalom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 index 913554159..adbd16173 100644 --- a/base/comm/psb_covrl.f90 +++ b/base/comm/psb_covrl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -67,28 +67,28 @@ subroutine psb_covrl_vect(x,desc_a,info,update,mode) use psi_mod implicit none - type(psb_c_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_c_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_covrl_vect' + name = 'psb_covrlv' 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() + ctxt=desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -136,7 +136,8 @@ subroutine psb_covrl_vect(x,desc_a,info,update,mode) ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_,cone,x%v,desc_a,info,data=psb_comm_ovr_) + call psi_swapdata(mode_,cone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then @@ -183,33 +184,33 @@ end subroutine psb_covrl_vect ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -subroutine psb_covrl_multivect(x,desc_a,info,update,mode) +subroutine psb_covrl_multivect(x,desc_a,info,update,mode) use psb_base_mod, psb_protect_name => psb_covrl_multivect use psi_mod implicit none - type(psb_c_multivect_type), intent(inout) :: x + type(psb_c_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_covrl_multivect' + name = 'psb_covrlv' 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() + ctxt = desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -244,7 +245,7 @@ subroutine psb_covrl_multivect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) + mode_ = psb_comm_status_sync_ endif do_swap = (mode_ /= 0) @@ -252,14 +253,16 @@ subroutine psb_covrl_multivect(x,desc_a,info,update,mode) if (ldx < ncol) call x%reall(ncol,x%get_ncols(),info) if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_reall' + info=psb_err_from_subroutine_ + ch_err='psb_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_,cone,x%v, desc_a,info,data=psb_comm_ovr_) + call psi_swapdata(mode_,cone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then diff --git a/base/comm/psb_covrl_a.f90 b/base/comm/psb_covrl_a.f90 index d42bcd943..98eae90e8 100644 --- a/base/comm/psb_covrl_a.f90 +++ b/base/comm/psb_covrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -30,7 +30,7 @@ ! ! ! -! File: psb_covrl_a.f90 +! File: psb_covrl.f90 ! ! Subroutine: psb_covrlm ! This subroutine performs the exchange of the overlap elements in a @@ -208,7 +208,7 @@ end subroutine psb_covrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index 8d1235dbe..5121c2152 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_cscatter_a.F90 b/base/comm/psb_cscatter_a.F90 index f351b0b02..dadf13c5c 100644 --- a/base/comm/psb_cscatter_a.F90 +++ b/base/comm/psb_cscatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_cscatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 9cfb6b596..f31659a1d 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index ed0591e81..443ef2f08 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dgather_a.f90 b/base/comm/psb_dgather_a.f90 index 1e03ccfd1..14ce53a12 100644 --- a/base/comm/psb_dgather_a.f90 +++ b/base/comm/psb_dgather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_dgatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index 24223485d..66be2ad7f 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -51,36 +51,35 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data) +subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data) use psb_base_mod, psb_protect_name => psb_dhalo_vect use psi_mod - use psb_comm_factory_mod - implicit none - type(psb_d_vect_type), intent(inout) :: x + type(psb_d_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: tran integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode,data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_dhalo_vect' + name = 'psb_dhalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if - ctxt=desc_a%get_context() + ctxt = desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -128,7 +127,6 @@ subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data) goto 9999 end if - ! exchange halo elements if(tran_ == 'N') then call psi_swapdata(imode,dzero,x%v,desc_a,info,data=data_) @@ -141,7 +139,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data) end if if (info /= psb_success_) then - ch_err = 'PSI_swapdata' + ch_err='PSI_swapdata' call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) goto 9999 end if @@ -180,26 +178,27 @@ subroutine psb_dhalo_multivect(x,desc_a,info,tran,mode,data) use psi_mod implicit none - type(psb_d_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: tran - integer(psb_ipk_), intent(in), optional :: mode,data + type(psb_d_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_dhalo_multivect' + name = 'psb_dhalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -240,7 +239,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = psb_comm_mov_ + imode = psb_comm_status_sync_ endif if (lldx < ncol) call x%reall(ncol,x%get_ncols(),info) diff --git a/base/comm/psb_dhalo_a.f90 b/base/comm/psb_dhalo_a.f90 index f068db270..4fc2ef4de 100644 --- a/base/comm/psb_dhalo_a.f90 +++ b/base/comm/psb_dhalo_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -52,7 +52,7 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) +subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_dhalom use psi_mod implicit none @@ -217,7 +217,7 @@ end subroutine psb_dhalom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index 77d1596cd..24d21897a 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -65,31 +65,30 @@ subroutine psb_dovrl_vect(x,desc_a,info,update,mode) use psb_base_mod, psb_protect_name => psb_dovrl_vect use psi_mod - use psb_comm_factory_mod implicit none - type(psb_d_vect_type), intent(inout) :: x + type(psb_d_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_dovrl_vect' + name = 'psb_dovrlv' 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() + ctxt=desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -122,7 +121,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = psb_comm_status_sync_ + mode_ = IOR(psb_swap_send_,psb_swap_recv_) endif do_swap = (mode_ /= 0) @@ -137,7 +136,8 @@ subroutine psb_dovrl_vect(x,desc_a,info,update,mode) ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_, done, x%v, desc_a, info, data=psb_comm_ovr_) + call psi_swapdata(mode_,done,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then @@ -184,33 +184,33 @@ end subroutine psb_dovrl_vect ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -subroutine psb_dovrl_multivect(x,desc_a,info,update,mode) +subroutine psb_dovrl_multivect(x,desc_a,info,update,mode) use psb_base_mod, psb_protect_name => psb_dovrl_multivect use psi_mod implicit none type(psb_d_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_dovrl_multivect' + name = 'psb_dovrlv' 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() + ctxt = desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -245,7 +245,7 @@ subroutine psb_dovrl_multivect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) + mode_ = psb_comm_status_sync_ endif do_swap = (mode_ /= 0) @@ -253,14 +253,16 @@ subroutine psb_dovrl_multivect(x,desc_a,info,update,mode) if (ldx < ncol) call x%reall(ncol,x%get_ncols(),info) if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_reall' + info=psb_err_from_subroutine_ + ch_err='psb_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_, done, x%v, desc_a, info, data=psb_comm_ovr_) + call psi_swapdata(mode_,done,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then diff --git a/base/comm/psb_dovrl_a.f90 b/base/comm/psb_dovrl_a.f90 index 464b8e31e..c45638213 100644 --- a/base/comm/psb_dovrl_a.f90 +++ b/base/comm/psb_dovrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -208,7 +208,7 @@ end subroutine psb_dovrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index 3465333b6..559922c8f 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dscatter_a.F90 b/base/comm/psb_dscatter_a.F90 index 8864cca8c..739e1aaa8 100644 --- a/base/comm/psb_dscatter_a.F90 +++ b/base/comm/psb_dscatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_dscatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index c7348cd92..e38cb89ad 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_egather_a.f90 b/base/comm/psb_egather_a.f90 index b777cebd7..36ddb6abd 100644 --- a/base/comm/psb_egather_a.f90 +++ b/base/comm/psb_egather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_egatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_ehalo_a.f90 b/base/comm/psb_ehalo_a.f90 index 712ae961f..742d539a3 100644 --- a/base/comm/psb_ehalo_a.f90 +++ b/base/comm/psb_ehalo_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -52,7 +52,7 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) +subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_ehalom use psi_mod implicit none @@ -174,7 +174,7 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) & desc_a,iwork,info,data=data_) else if((tran_ == 'T').or.(tran_ == 'C')) then call psi_swaptran(imode,k,eone,xp,& - & desc_a,iwork,info) + &desc_a,iwork,info) else info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid tran') @@ -217,7 +217,7 @@ end subroutine psb_ehalom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -254,7 +254,7 @@ end subroutine psb_ehalom ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) +subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_ehalov use psi_mod implicit none diff --git a/base/comm/psb_eovrl_a.f90 b/base/comm/psb_eovrl_a.f90 index b24e5ab83..5c2354dd6 100644 --- a/base/comm/psb_eovrl_a.f90 +++ b/base/comm/psb_eovrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -208,7 +208,7 @@ end subroutine psb_eovrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_escatter_a.F90 b/base/comm/psb_escatter_a.F90 index 9c5ed19df..f5cd08e8e 100644 --- a/base/comm/psb_escatter_a.F90 +++ b/base/comm/psb_escatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_escatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_i2gather_a.f90 b/base/comm/psb_i2gather_a.f90 index e0e1ed7a7..b8eb80bf9 100644 --- a/base/comm/psb_i2gather_a.f90 +++ b/base/comm/psb_i2gather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_i2gatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_i2halo_a.f90 b/base/comm/psb_i2halo_a.f90 index 054b61beb..1ae795a12 100644 --- a/base/comm/psb_i2halo_a.f90 +++ b/base/comm/psb_i2halo_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -217,7 +217,7 @@ end subroutine psb_i2halom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_i2ovrl_a.f90 b/base/comm/psb_i2ovrl_a.f90 index 09cc3b5d1..1501efcea 100644 --- a/base/comm/psb_i2ovrl_a.f90 +++ b/base/comm/psb_i2ovrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -208,7 +208,7 @@ end subroutine psb_i2ovrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_i2scatter_a.F90 b/base/comm/psb_i2scatter_a.F90 index 1a07587f0..2da1bcab2 100644 --- a/base/comm/psb_i2scatter_a.F90 +++ b/base/comm/psb_i2scatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_i2scatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index acfdf52aa..1d8db00d6 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index 9ca4080cd..b5ffbbb49 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -51,31 +51,32 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_ihalo_vect(x,desc_a,info,tran,mode,data) +subroutine psb_ihalo_vect(x,desc_a,info,tran,mode,data) use psb_base_mod, psb_protect_name => psb_ihalo_vect use psi_mod implicit none - type(psb_i_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_i_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode,data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_ihalo_vect' + name = 'psb_ihalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -115,7 +116,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if ((info == 0).and.(lldx psb_iovrl_multivect use psi_mod implicit none - type(psb_i_multivect_type), intent(inout) :: x + type(psb_i_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_iovrl_multivect' + name = 'psb_iovrlv' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ - goto 9999 + info = psb_err_internal_error_ ; goto 9999 end if ctxt = desc_a%get_context() @@ -245,7 +245,7 @@ subroutine psb_iovrl_multivect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) + mode_ = psb_comm_status_sync_ endif do_swap = (mode_ /= 0) @@ -253,14 +253,16 @@ subroutine psb_iovrl_multivect(x,desc_a,info,update,mode) if (ldx < ncol) call x%reall(ncol,x%get_ncols(),info) if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_reall' + info=psb_err_from_subroutine_ + ch_err='psb_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_,ione,x%v,desc_a,info,data=psb_comm_ovr_) + call psi_swapdata(mode_,ione,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index 57268e71f..607a4c9be 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_ispgather.F90 b/base/comm/psb_ispgather.F90 index 50319debb..bfb43ce7c 100644 --- a/base/comm/psb_ispgather.F90 +++ b/base/comm/psb_ispgather.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_lgather.f90 b/base/comm/psb_lgather.f90 index 17359bce8..d629b90d5 100644 --- a/base/comm/psb_lgather.f90 +++ b/base/comm/psb_lgather.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_lhalo.f90 b/base/comm/psb_lhalo.f90 index 322ba72ae..b4fb42917 100644 --- a/base/comm/psb_lhalo.f90 +++ b/base/comm/psb_lhalo.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -51,31 +51,31 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_lhalo_vect(x,desc_a,info,tran,mode,data) +subroutine psb_lhalo_vect(x,desc_a,info,tran,mode,data) use psb_base_mod, psb_protect_name => psb_lhalo_vect use psi_mod implicit none - type(psb_l_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & - & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name = 'psb_lhalo_vect' + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + & nrow, ncol, lldx, imode,data_ + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name = 'psb_lhalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ + info = psb_err_internal_error_ goto 9999 end if @@ -116,14 +116,13 @@ subroutine psb_lhalo_vect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if ((info == 0).and.(lldx psb_lovrl_multivect use psi_mod implicit none type(psb_l_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_lovrl_multivect' + name = 'psb_lovrlv' 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() + ctxt = desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -244,7 +245,7 @@ subroutine psb_lovrl_multivect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) + mode_ = psb_comm_status_sync_ endif do_swap = (mode_ /= 0) @@ -252,14 +253,16 @@ subroutine psb_lovrl_multivect(x,desc_a,info,update,mode) if (ldx < ncol) call x%reall(ncol,x%get_ncols(),info) if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_reall' + info=psb_err_from_subroutine_ + ch_err='psb_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_,lone,x%v,desc_a,info,data=psb_comm_ovr_) + call psi_swapdata(mode_,lone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then diff --git a/base/comm/psb_lscatter.F90 b/base/comm/psb_lscatter.F90 index 0ebbe28eb..fb80711bd 100644 --- a/base/comm/psb_lscatter.F90 +++ b/base/comm/psb_lscatter.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_lspgather.F90 b/base/comm/psb_lspgather.F90 index 5bab14448..1e8dcf65d 100644 --- a/base/comm/psb_lspgather.F90 +++ b/base/comm/psb_lspgather.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_mgather_a.f90 b/base/comm/psb_mgather_a.f90 index df574ea29..7f94883fc 100644 --- a/base/comm/psb_mgather_a.f90 +++ b/base/comm/psb_mgather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_mgatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_mhalo_a.f90 b/base/comm/psb_mhalo_a.f90 index c3f6a6889..0b020d81e 100644 --- a/base/comm/psb_mhalo_a.f90 +++ b/base/comm/psb_mhalo_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -217,7 +217,7 @@ end subroutine psb_mhalom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_movrl_a.f90 b/base/comm/psb_movrl_a.f90 index 983bcbf81..607674dd2 100644 --- a/base/comm/psb_movrl_a.f90 +++ b/base/comm/psb_movrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -208,7 +208,7 @@ end subroutine psb_movrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_mscatter_a.F90 b/base/comm/psb_mscatter_a.F90 index 628fcf19d..847320adb 100644 --- a/base/comm/psb_mscatter_a.F90 +++ b/base/comm/psb_mscatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_mscatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 59cecc175..d095ba456 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_sgather_a.f90 b/base/comm/psb_sgather_a.f90 index 28d5f5dca..d19d31a12 100644 --- a/base/comm/psb_sgather_a.f90 +++ b/base/comm/psb_sgather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_sgatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index 366f3713f..0a4ce01d9 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -51,31 +51,32 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_shalo_vect(x,desc_a,info,tran,mode,data) +subroutine psb_shalo_vect(x,desc_a,info,tran,mode,data) use psb_base_mod, psb_protect_name => psb_shalo_vect use psi_mod implicit none - type(psb_s_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_s_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & - & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name = 'psb_shalo_vect' + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + & nrow, ncol, lldx, imode,data_ + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name = 'psb_shalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -115,23 +116,22 @@ subroutine psb_shalo_vect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if ((info == 0).and.(lldx psb_shalom use psi_mod implicit none @@ -217,7 +217,7 @@ end subroutine psb_shalom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 index 9ca9c6b4e..0300e10e6 100644 --- a/base/comm/psb_sovrl.f90 +++ b/base/comm/psb_sovrl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -67,28 +67,28 @@ subroutine psb_sovrl_vect(x,desc_a,info,update,mode) use psi_mod implicit none - type(psb_s_vect_type), intent(inout) :: x + type(psb_s_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_sovrl_vect' + name = 'psb_sovrlv' 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() + ctxt=desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -136,14 +136,15 @@ subroutine psb_sovrl_vect(x,desc_a,info,update,mode) ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_, sone, x%v, desc_a, info, data=psb_comm_ovr_) + call psi_swapdata(mode_,sone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -183,26 +184,26 @@ end subroutine psb_sovrl_vect ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -subroutine psb_sovrl_multivect(x,desc_a,info,update,mode) +subroutine psb_sovrl_multivect(x,desc_a,info,update,mode) use psb_base_mod, psb_protect_name => psb_sovrl_multivect use psi_mod implicit none - type(psb_s_multivect_type), intent(inout) :: x + type(psb_s_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_sovrl_multivect' + name = 'psb_sovrlv' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -244,7 +245,7 @@ subroutine psb_sovrl_multivect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) + mode_ = psb_comm_status_sync_ endif do_swap = (mode_ /= 0) @@ -252,14 +253,16 @@ subroutine psb_sovrl_multivect(x,desc_a,info,update,mode) if (ldx < ncol) call x%reall(ncol,x%get_ncols(),info) if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_reall' + info=psb_err_from_subroutine_ + ch_err='psb_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_, sone, x%v, desc_a, info, data=psb_comm_ovr_) + call psi_swapdata(mode_,sone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then diff --git a/base/comm/psb_sovrl_a.f90 b/base/comm/psb_sovrl_a.f90 index 6ced0fd57..ddce2b2bb 100644 --- a/base/comm/psb_sovrl_a.f90 +++ b/base/comm/psb_sovrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -208,7 +208,7 @@ end subroutine psb_sovrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index f2b79e839..802be716b 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_sscatter_a.F90 b/base/comm/psb_sscatter_a.F90 index e060bd1c8..ae8525d32 100644 --- a/base/comm/psb_sscatter_a.F90 +++ b/base/comm/psb_sscatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_sscatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index d6317de22..14efe3539 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index 5cf445a9b..b4bf15b7e 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zgather_a.f90 b/base/comm/psb_zgather_a.f90 index fa5f288b5..0b702835d 100644 --- a/base/comm/psb_zgather_a.f90 +++ b/base/comm/psb_zgather_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -189,7 +189,7 @@ end subroutine psb_zgatherm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index b3e37d027..beed0238c 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -51,31 +51,32 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_zhalo_vect(x,desc_a,info,tran,mode,data) +subroutine psb_zhalo_vect(x,desc_a,info,tran,mode,data) use psb_base_mod, psb_protect_name => psb_zhalo_vect use psi_mod implicit none - type(psb_z_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_z_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & - & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name = 'psb_zhalo_vect' + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + & nrow, ncol, lldx, imode,data_ + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name = 'psb_zhalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -115,7 +116,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if ((info == 0).and.(lldx psb_zhalo_multivect use psi_mod implicit none type(psb_z_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, iix, jjx, & & nrow, ncol, lldx, imode, data_ - integer(psb_lpk_) :: m, n, ix, ijx - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_zhalo_multivect' + name = 'psb_zhalov' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -237,7 +239,7 @@ subroutine psb_zhalo_multivect(x,desc_a,info,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = psb_comm_status_sync_ endif if (lldx < ncol) call x%reall(ncol,x%get_ncols(),info) diff --git a/base/comm/psb_zhalo_a.f90 b/base/comm/psb_zhalo_a.f90 index 2acc24631..fac264995 100644 --- a/base/comm/psb_zhalo_a.f90 +++ b/base/comm/psb_zhalo_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -217,7 +217,7 @@ end subroutine psb_zhalom !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 60a8a76ad..00c376710 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -67,21 +67,21 @@ subroutine psb_zovrl_vect(x,desc_a,info,update,mode) use psi_mod implicit none - type(psb_z_vect_type), intent(inout) :: x + type(psb_z_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_zovrl_vect' + name = 'psb_zovrlv' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -136,7 +136,8 @@ subroutine psb_zovrl_vect(x,desc_a,info,update,mode) ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_,zone,x%v,desc_a,info,data=psb_comm_ovr_) + call psi_swapdata(mode_,zone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then @@ -183,26 +184,26 @@ end subroutine psb_zovrl_vect ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -subroutine psb_zovrl_multivect(x,desc_a,info,update,mode) +subroutine psb_zovrl_multivect(x,desc_a,info,update,mode) use psb_base_mod, psb_protect_name => psb_zovrl_multivect use psi_mod implicit none type(psb_z_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & + integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, & & nrow, ncol, ldx, data_, update_, mode_ - integer(psb_lpk_) :: m, n, ix, ijx - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw + integer(psb_lpk_) :: m, n, ix, ijx + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw - name = 'psb_zovrl_multivect' + name = 'psb_zovrlv' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -244,7 +245,7 @@ subroutine psb_zovrl_multivect(x,desc_a,info,update,mode) if (present(mode)) then mode_ = mode else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) + mode_ = psb_comm_status_sync_ endif do_swap = (mode_ /= 0) @@ -252,14 +253,16 @@ subroutine psb_zovrl_multivect(x,desc_a,info,update,mode) if (ldx < ncol) call x%reall(ncol,x%get_ncols(),info) if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_reall' + info=psb_err_from_subroutine_ + ch_err='psb_reall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if ! exchange overlap elements if (do_swap) then - call psi_swapdata(mode_,zone,x%v,desc_a,info,data=psb_comm_ovr_) + call psi_swapdata(mode_,zone,x%v,& + & desc_a,info,data=psb_comm_ovr_) end if if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) if (info /= psb_success_) then diff --git a/base/comm/psb_zovrl_a.f90 b/base/comm/psb_zovrl_a.f90 index e7a87cef8..f95b827ac 100644 --- a/base/comm/psb_zovrl_a.f90 +++ b/base/comm/psb_zovrl_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -208,7 +208,7 @@ end subroutine psb_zovrlm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index f8d2102b6..aae8efd34 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zscatter_a.F90 b/base/comm/psb_zscatter_a.F90 index d51dc82ac..5321905ae 100644 --- a/base/comm/psb_zscatter_a.F90 +++ b/base/comm/psb_zscatter_a.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -262,7 +262,7 @@ end subroutine psb_zscatterm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index 5d4a809b3..5533b5095 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/Makefile b/base/modules/Makefile index 7d4a1b362..7ab71d300 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -33,22 +33,26 @@ SERIAL_MODS=serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ comm/comm_schemes/psb_comm_neighbor_impl_mod.o \ comm/comm_schemes/psb_comm_rma_mod.o \ comm/comm_schemes/psb_comm_factory_mod.o \ + serial/psb_i2_base_vect_mod.o serial/psb_i2_vect_mod.o\ serial/psb_i_base_vect_mod.o serial/psb_i_vect_mod.o\ serial/psb_l_base_vect_mod.o serial/psb_l_vect_mod.o\ serial/psb_d_base_vect_mod.o serial/psb_d_vect_mod.o\ serial/psb_s_base_vect_mod.o serial/psb_s_vect_mod.o\ serial/psb_c_base_vect_mod.o serial/psb_c_vect_mod.o\ serial/psb_z_base_vect_mod.o serial/psb_z_vect_mod.o\ - serial/psb_vect_mod.o\ - auxil/psi_serial_mod.o auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ + serial/psb_vect_mod.o \ + auxil/psi_serial_mod.o \ + auxil/psi_i2_serial_mod.o auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o \ auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ - psi_mod.o psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\ + psi_mod.o psi_i2_mod.o psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\ auxil/psb_ip_reord_mod.o\ auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o \ auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ auxil/psb_c_ip_reord_mod.o auxil/psb_z_ip_reord_mod.o \ + auxil/psb_i2_hsort_mod.o auxil/psb_i2_isort_mod.o \ + auxil/psb_i2_msort_mod.o auxil/psb_i2_qsort_mod.o \ auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ @@ -108,6 +112,7 @@ UTIL_MODS = desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ comm/psb_s_comm_a_mod.o comm/psb_d_comm_a_mod.o\ comm/psb_c_comm_a_mod.o comm/psb_z_comm_a_mod.o \ comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \ + comm/psi_i2_comm_a_mod.o comm/psi_i2_comm_v_mod.o \ comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o \ comm/psi_i_comm_v_mod.o comm/psi_l_comm_v_mod.o \ @@ -142,6 +147,7 @@ $(LIBDIR)/$(LIBNAME): objs $(OBJS): $(MODULES) psb_error_mod.o: psb_const_mod.o psb_realloc_mod.o \ + auxil/psb_i2_realloc_mod.o \ auxil/psb_m_realloc_mod.o \ auxil/psb_e_realloc_mod.o \ auxil/psb_s_realloc_mod.o \ @@ -154,6 +160,7 @@ penv/psi_collective_mod.o penv/psi_p2p_mod.o: penv/psi_penv_mod.o psb_realloc_mod.o: auxil/psb_m_realloc_mod.o \ auxil/psb_e_realloc_mod.o \ + auxil/psb_i2_realloc_mod.o \ auxil/psb_s_realloc_mod.o \ auxil/psb_d_realloc_mod.o \ auxil/psb_c_realloc_mod.o \ @@ -184,7 +191,7 @@ penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_m auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o \ -auxil/psb_string_mod.o auxil/psb_m_realloc_mod.o auxil/psb_e_realloc_mod.o auxil/psb_s_realloc_mod.o \ +auxil/psb_string_mod.o auxil/psb_i2_realloc_mod.o auxil/psb_m_realloc_mod.o auxil/psb_e_realloc_mod.o \ auxil/psb_d_realloc_mod.o auxil/psb_c_realloc_mod.o auxil/psb_z_realloc_mod.o \ desc/psb_desc_const_mod.o psi_penv_mod.o: psb_const_mod.o @@ -209,6 +216,8 @@ auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ auxil/psb_e_msort_mod.o auxil/psb_e_qsort_mod.o \ + auxil/psb_i2_hsort_mod.o auxil/psb_i2_isort_mod.o \ + auxil/psb_i2_msort_mod.o auxil/psb_i2_qsort_mod.o \ auxil/psb_s_hsort_mod.o auxil/psb_s_isort_mod.o \ auxil/psb_s_msort_mod.o auxil/psb_s_qsort_mod.o \ auxil/psb_d_hsort_mod.o auxil/psb_d_isort_mod.o \ @@ -230,6 +239,8 @@ auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ auxil/psb_e_msort_mod.o auxil/psb_e_qsort_mod.o \ +auxil/psb_i2_hsort_mod.o auxil/psb_i2_isort_mod.o \ +auxil/psb_i2_msort_mod.o auxil/psb_i2_qsort_mod.o \ auxil/psb_s_hsort_mod.o auxil/psb_s_isort_mod.o \ auxil/psb_s_msort_mod.o auxil/psb_s_qsort_mod.o \ auxil/psb_d_hsort_mod.o auxil/psb_d_isort_mod.o \ @@ -248,20 +259,20 @@ auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ auxil/psb_c_ip_reord_mod.o auxil/psb_z_ip_reord_mod.o : psb_realloc_mod.o psb_const_mod.o - -auxil/psb_i_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o +auxil/psb_i2_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o auxil/psb_i2_hsort_mod.o +auxil/psb_i_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o auxil/psb_i2_hsort_mod.o auxil/psb_l_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o auxil/psb_s_hsort_x_mod.o: auxil/psb_s_hsort_mod.o auxil/psb_d_hsort_x_mod.o: auxil/psb_d_hsort_mod.o auxil/psb_c_hsort_x_mod.o: auxil/psb_c_hsort_mod.o auxil/psb_z_hsort_x_mod.o: auxil/psb_z_hsort_mod.o -auxil/psi_serial_mod.o: auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ +auxil/psi_serial_mod.o: auxil/psi_i2_serial_mod.o auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o\ auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ auxil/psi_acx_mod.o auxil/psi_alcx_mod.o auxil/psi_lcx_mod.o -auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o: psb_const_mod.o +auxil/psi_i2_serial_mod.o auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o: psb_const_mod.o auxil/psb_ip_reord_mod.o: auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ @@ -276,13 +287,13 @@ serial/psb_s_base_mat_mod.o serial/psb_d_base_mat_mod.o serial/psb_c_base_mat_mo serial/psb_s_base_mat_mod.o: serial/psb_s_base_vect_mod.o serial/psb_d_base_mat_mod.o: serial/psb_d_base_vect_mod.o #serial/psb_ld_base_mat_mod.o: serial/psb_d_base_vect_mod.o -serial/psb_c_base_mat_mod.o: serial/psb_c_base_vect_mod.o -serial/psb_z_base_mat_mod.o: serial/psb_z_base_vect_mod.o -serial/psb_l_base_vect_mod.o: serial/psb_i_base_vect_mod.o -serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o comm/comm_schemes/psb_comm_neighbor_impl_mod.o -serial/psb_d_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o comm/comm_schemes/psb_comm_schemes_mod.o comm/comm_schemes/psb_comm_factory_mod.o +serial/psb_c_base_mat_mod.o: serial/psb_c_base_vect_mod.o +serial/psb_z_base_mat_mod.o: serial/psb_z_base_vect_mod.o +serial/psb_i2_base_vect_mod.o: serial/psb_i_base_vect_mod.o comm/comm_schemes/psb_comm_schemes_mod.o comm/comm_schemes/psb_comm_factory_mod.o +serial/psb_l_base_vect_mod.o: serial/psb_i_base_vect_mod.o comm/comm_schemes/psb_comm_schemes_mod.o comm/comm_schemes/psb_comm_factory_mod.o +serial/psb_d_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o comm/comm_schemes/psb_comm_neighbor_impl_mod.o comm/comm_schemes/psb_comm_schemes_mod.o comm/comm_schemes/psb_comm_factory_mod.o serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: auxil/psi_serial_mod.o psb_realloc_mod.o comm/comm_schemes/psb_comm_neighbor_impl_mod.o \ - comm/psb_neighbor_topology_mod.o + comm/psb_neighbor_topology_mod.o comm/comm_schemes/psb_comm_schemes_mod.o comm/comm_schemes/psb_comm_factory_mod.o comm/comm_schemes/psb_comm_schemes_mod.o comm/comm_schemes/psb_comm_factory_mod.o serial/psb_s_mat_mod.o: serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_vect_mod.o \ serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o serial/psb_d_mat_mod.o: serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_vect_mod.o \ @@ -299,6 +310,7 @@ serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_lz_csr_mat_mod. serial/psb_mat_mod.o: serial/psb_vect_mod.o serial/psb_s_mat_mod.o serial/psb_d_mat_mod.o serial/psb_c_mat_mod.o serial/psb_z_mat_mod.o serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o auxil/psi_serial_mod.o serial/psb_i_vect_mod.o: serial/psb_i_base_vect_mod.o +serial/psb_i2_vect_mod.o: serial/psb_i2_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o: serial/psb_l_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_s_vect_mod.o: serial/psb_s_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_d_vect_mod.o: serial/psb_d_base_vect_mod.o serial/psb_i_vect_mod.o @@ -324,10 +336,12 @@ desc/psb_desc_mod.o: psb_penv_mod.o psb_realloc_mod.o\ desc/psb_repl_map_mod.o desc/psb_gen_block_map_mod.o desc/psb_desc_const_mod.o\ desc/psb_indx_map_mod.o serial/psb_i_vect_mod.o +psi_i2_mod.o: desc/psb_desc_mod.o serial/psb_i2_vect_mod.o comm/psi_e_comm_a_mod.o \ + comm/psi_m_comm_a_mod.o comm/psi_i_comm_v_mod.o comm/psi_i2_comm_a_mod.o comm/psi_i2_comm_v_mod.o psi_i_mod.o: desc/psb_desc_mod.o serial/psb_i_vect_mod.o comm/psi_e_comm_a_mod.o \ - comm/psi_m_comm_a_mod.o comm/psi_i_comm_v_mod.o + comm/psi_m_comm_a_mod.o comm/psi_i_comm_v_mod.o comm/psi_i2_comm_a_mod.o comm/psi_i2_comm_v_mod.o psi_l_mod.o: desc/psb_desc_mod.o serial/psb_l_vect_mod.o comm/psi_e_comm_a_mod.o \ - comm/psi_m_comm_a_mod.o comm/psi_l_comm_v_mod.o + comm/psi_m_comm_a_mod.o comm/psi_l_comm_v_mod.o comm/psi_i2_comm_a_mod.o comm/psi_i2_comm_v_mod.o psi_s_mod.o: desc/psb_desc_mod.o serial/psb_s_vect_mod.o comm/psi_s_comm_a_mod.o \ comm/psi_s_comm_v_mod.o psi_d_mod.o: desc/psb_desc_mod.o serial/psb_d_vect_mod.o comm/psi_d_comm_a_mod.o \ @@ -337,7 +351,7 @@ psi_c_mod.o: desc/psb_desc_mod.o serial/psb_c_vect_mod.o comm/psi_c_comm_a_mod.o psi_z_mod.o: desc/psb_desc_mod.o serial/psb_z_vect_mod.o comm/psi_z_comm_a_mod.o \ comm/psi_z_comm_v_mod.o psi_mod.o: psb_penv_mod.o desc/psb_desc_mod.o auxil/psi_serial_mod.o serial/psb_serial_mod.o\ - psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o + psi_i2_mod.o psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o desc/psb_indx_map_mod.o: desc/psb_desc_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o auxil/psb_sort_mod.o desc/psb_hash_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o desc/psb_gen_block_map_mod.o:\ @@ -376,6 +390,8 @@ comm/psb_d_comm_mod.o: serial/psb_d_vect_mod.o desc/psb_desc_mod.o serial/psb_ma comm/psb_c_comm_mod.o: serial/psb_c_vect_mod.o desc/psb_desc_mod.o serial/psb_mat_mod.o comm/psb_z_comm_mod.o: serial/psb_z_vect_mod.o desc/psb_desc_mod.o serial/psb_mat_mod.o +comm/psi_i2_comm_v_mod.o: serial/psb_i2_vect_mod.o comm/psi_i2_comm_a_mod.o \ + comm/psi_m_comm_a_mod.o comm/psi_i_comm_v_mod.o: serial/psb_i_vect_mod.o comm/psi_e_comm_a_mod.o \ comm/psi_m_comm_a_mod.o comm/psi_l_comm_v_mod.o: serial/psb_l_vect_mod.o comm/psi_e_comm_a_mod.o \ @@ -385,7 +401,7 @@ comm/psi_d_comm_v_mod.o: serial/psb_d_vect_mod.o comm/psi_d_comm_a_mod.o comm/psi_c_comm_v_mod.o: serial/psb_c_vect_mod.o comm/psi_c_comm_a_mod.o comm/psi_z_comm_v_mod.o: serial/psb_z_vect_mod.o comm/psi_z_comm_a_mod.o -comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \ +comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o comm/psi_i2_comm_a_mod.o \ comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o: desc/psb_desc_mod.o diff --git a/base/modules/auxil/psb_c_hsort_mod.f90 b/base/modules/auxil/psb_c_hsort_mod.f90 index 863614c9a..ad375db79 100644 --- a/base/modules/auxil/psb_c_hsort_mod.f90 +++ b/base/modules/auxil/psb_c_hsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_hsort_x_mod.f90 b/base/modules/auxil/psb_c_hsort_x_mod.f90 index 8f0437f7c..1787a77b7 100644 --- a/base/modules/auxil/psb_c_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_c_hsort_x_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_ip_reord_mod.F90 b/base/modules/auxil/psb_c_ip_reord_mod.F90 index daec3a65f..99b3354e9 100644 --- a/base/modules/auxil/psb_c_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_c_ip_reord_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_isort_mod.f90 b/base/modules/auxil/psb_c_isort_mod.f90 index 302a2d8ec..bc46e9516 100644 --- a/base/modules/auxil/psb_c_isort_mod.f90 +++ b/base/modules/auxil/psb_c_isort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_msort_mod.f90 b/base/modules/auxil/psb_c_msort_mod.f90 index 54103747c..efd5fb7ad 100644 --- a/base/modules/auxil/psb_c_msort_mod.f90 +++ b/base/modules/auxil/psb_c_msort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_qsort_mod.f90 b/base/modules/auxil/psb_c_qsort_mod.f90 index 178fdc721..b055fc07c 100644 --- a/base/modules/auxil/psb_c_qsort_mod.f90 +++ b/base/modules/auxil/psb_c_qsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 index 9b3ada6e4..f3669f69e 100644 --- a/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 +++ b/base/modules/auxil/psb_c_rb_idx_tree_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 16be31838..dae4f8974 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_hsort_mod.f90 b/base/modules/auxil/psb_d_hsort_mod.f90 index e9d10a706..d54886471 100644 --- a/base/modules/auxil/psb_d_hsort_mod.f90 +++ b/base/modules/auxil/psb_d_hsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_hsort_x_mod.f90 b/base/modules/auxil/psb_d_hsort_x_mod.f90 index ba45d6833..adefb3c46 100644 --- a/base/modules/auxil/psb_d_hsort_x_mod.f90 +++ b/base/modules/auxil/psb_d_hsort_x_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_ip_reord_mod.F90 b/base/modules/auxil/psb_d_ip_reord_mod.F90 index 7cd0a2699..229cafc5e 100644 --- a/base/modules/auxil/psb_d_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_d_ip_reord_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_isort_mod.f90 b/base/modules/auxil/psb_d_isort_mod.f90 index e5e2a09a6..f59e1cc07 100644 --- a/base/modules/auxil/psb_d_isort_mod.f90 +++ b/base/modules/auxil/psb_d_isort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_msort_mod.f90 b/base/modules/auxil/psb_d_msort_mod.f90 index 3c4559bfe..b9acd7cdf 100644 --- a/base/modules/auxil/psb_d_msort_mod.f90 +++ b/base/modules/auxil/psb_d_msort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_qsort_mod.f90 b/base/modules/auxil/psb_d_qsort_mod.f90 index 4a9953d8b..ca547cd2e 100644 --- a/base/modules/auxil/psb_d_qsort_mod.f90 +++ b/base/modules/auxil/psb_d_qsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 b/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 index 099d1a305..b68326d0b 100644 --- a/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 +++ b/base/modules/auxil/psb_d_rb_idx_tree_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index ae093a4a3..96d094d5a 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_e_hsort_mod.f90 b/base/modules/auxil/psb_e_hsort_mod.f90 index 3bc38743a..5789c680e 100644 --- a/base/modules/auxil/psb_e_hsort_mod.f90 +++ b/base/modules/auxil/psb_e_hsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_e_ip_reord_mod.F90 b/base/modules/auxil/psb_e_ip_reord_mod.F90 index 7369d1f2f..7b018cab1 100644 --- a/base/modules/auxil/psb_e_ip_reord_mod.F90 +++ b/base/modules/auxil/psb_e_ip_reord_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_e_isort_mod.f90 b/base/modules/auxil/psb_e_isort_mod.f90 index 4006c4120..dd859b7ec 100644 --- a/base/modules/auxil/psb_e_isort_mod.f90 +++ b/base/modules/auxil/psb_e_isort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_e_msort_mod.f90 b/base/modules/auxil/psb_e_msort_mod.f90 index ef9d5b8d6..0f1637afd 100644 --- a/base/modules/auxil/psb_e_msort_mod.f90 +++ b/base/modules/auxil/psb_e_msort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_e_qsort_mod.f90 b/base/modules/auxil/psb_e_qsort_mod.f90 index bfd9aa0d2..f3d2457e7 100644 --- a/base/modules/auxil/psb_e_qsort_mod.f90 +++ b/base/modules/auxil/psb_e_qsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 688753d88..b3749ced6 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_i2_hsort_mod.f90 b/base/modules/auxil/psb_i2_hsort_mod.f90 index 76f7c3fe8..9c5fc4985 100644 --- a/base/modules/auxil/psb_i2_hsort_mod.f90 +++ b/base/modules/auxil/psb_i2_hsort_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/auxil/psb_i2_hsort_x_mod.f90 b/base/modules/auxil/psb_i2_hsort_x_mod.f90 new file mode 100644 index 000000000..1c4d0ea8e --- /dev/null +++ b/base/modules/auxil/psb_i2_hsort_x_mod.f90 @@ -0,0 +1,312 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_i2_hsort_x_mod + use psb_const_mod + use psb_e_hsort_mod + use psb_m_hsort_mod + use psb_i2_hsort_mod + + type psb_i2_heap + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last + integer(psb_i2pk_), allocatable :: keys(:) + contains + procedure, pass(heap) :: init => psb_i2_init_heap + procedure, pass(heap) :: howmany => psb_i2_howmany + procedure, pass(heap) :: insert => psb_i2_insert_heap + procedure, pass(heap) :: get_first => psb_i2_heap_get_first + procedure, pass(heap) :: dump => psb_i2_dump_heap + procedure, pass(heap) :: free => psb_i2_free_heap + end type psb_i2_heap + + type psb_i2_idx_heap + integer(psb_ipk_) :: dir + integer(psb_ipk_) :: last + integer(psb_i2pk_), allocatable :: keys(:) + integer(psb_ipk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_i2_idx_init_heap + procedure, pass(heap) :: howmany => psb_i2_idx_howmany + procedure, pass(heap) :: insert => psb_i2_idx_insert_heap + procedure, pass(heap) :: get_first => psb_i2_idx_heap_get_first + procedure, pass(heap) :: dump => psb_i2_idx_dump_heap + procedure, pass(heap) :: free => psb_i2_idx_free_heap + end type psb_i2_idx_heap + + +contains + + subroutine psb_i2_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_i2_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_i2_init_heap + + + function psb_i2_howmany(heap) result(res) + implicit none + class(psb_i2_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_i2_howmany + + subroutine psb_i2_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + integer(psb_i2pk_), intent(in) :: key + class(psb_i2_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_i2_insert_heap + + subroutine psb_i2_heap_get_first(key,heap,info) + implicit none + + class(psb_i2_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_i2_heap_get_first + + subroutine psb_i2_dump_heap(iout,heap,info) + + implicit none + class(psb_i2_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) psb_comm_rma_init procedure, pass :: free => psb_comm_rma_free procedure, pass :: clear_memory_buffer_layout => psb_comm_rma_clear_memory_buffer_layout procedure, pass :: init_memory_buffer_layout => psb_comm_rma_ini_memory_buffer_layout + procedure, pass :: init_memory_buffer_layout_tran => psb_comm_rma_ini_memory_buffer_layout_tran procedure, pass :: set_swap_status => psb_comm_rma_set_swap_status procedure, pass :: get_swap_status => psb_comm_rma_get_swap_status end type psb_comm_rma_handle @@ -75,6 +79,9 @@ contains if (allocated(this%peer_remote_recv_displs)) deallocate(this%peer_remote_recv_displs) if (allocated(this%peer_send_indexes)) deallocate(this%peer_send_indexes) if (allocated(this%peer_recv_indexes)) deallocate(this%peer_recv_indexes) + if (allocated(this%notify_buf)) deallocate(this%notify_buf) + if (allocated(this%notify_recv_reqs)) deallocate(this%notify_recv_reqs) + if (allocated(this%notify_send_reqs)) deallocate(this%notify_send_reqs) this%layout_ready = .false. this%layout_nnbr = -1 @@ -115,6 +122,15 @@ contains info = psb_err_alloc_dealloc_ return end if + allocate(this%notify_buf(n_neighbors), this%notify_recv_reqs(n_neighbors), & + & this%notify_send_reqs(n_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + this%notify_buf = 0_psb_mpk_ + this%notify_recv_reqs = MPI_REQUEST_NULL + this%notify_send_reqs = MPI_REQUEST_NULL end if if (send_total > 0) then @@ -221,6 +237,139 @@ contains call this%clear_memory_buffer_layout(info) end subroutine psb_comm_rma_free + ! Transpose variant: peer_send_* is filled from comm_list RECV area, + ! peer_recv_* from comm_list SEND area. Metadata exchange tells peers our + ! recv displacement so they can GET/PUT to the correct location in swaptran. + ! layout_send = total_recv (effective send), layout_recv = total_send. + subroutine psb_comm_rma_ini_memory_buffer_layout_tran(this, info, comm_list, peer_mpi_rank, & + & num_neighbors, total_send, total_recv, my_rank, icomm) + class(psb_comm_rma_handle), intent(inout) :: this + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: comm_list(:) + integer(psb_ipk_), intent(in) :: peer_mpi_rank(:) + integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv + integer(psb_ipk_), intent(in) :: my_rank + integer(psb_mpk_), intent(in) :: icomm + + integer(psb_mpk_) :: iret, p2pstat(mpi_status_size), prc_rank + integer(psb_ipk_) :: n_neighbors, eff_send, eff_recv + integer(psb_ipk_) :: neighbor_idx, item_idx + integer(psb_ipk_) :: list_pos, send_offset, recv_offset + integer(psb_ipk_) :: proc_to_comm, actual_recv_count, actual_send_count + integer(psb_ipk_) :: local_meta(4), remote_meta(4) + + call this%clear_memory_buffer_layout(info) + if (info /= psb_success_) return + + n_neighbors = num_neighbors + ! For transpose: effective send = actual recv, effective recv = actual send + eff_send = total_recv + eff_recv = total_send + + if (n_neighbors > 0) then + allocate(this%peer_proc(n_neighbors), this%peer_send_counts(n_neighbors), & + & this%peer_recv_counts(n_neighbors), this%peer_send_displs(n_neighbors), & + & this%peer_recv_displs(n_neighbors), this%peer_mpi_rank(n_neighbors), & + & this%peer_remote_send_displs(n_neighbors), this%peer_remote_recv_displs(n_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + allocate(this%notify_buf(n_neighbors), this%notify_recv_reqs(n_neighbors), & + & this%notify_send_reqs(n_neighbors), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + this%notify_buf = 0_psb_mpk_ + this%notify_recv_reqs = MPI_REQUEST_NULL + this%notify_send_reqs = MPI_REQUEST_NULL + end if + + if (eff_send > 0) then + allocate(this%peer_send_indexes(eff_send), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + end if + + if (eff_recv > 0) then + allocate(this%peer_recv_indexes(eff_recv), stat=iret) + if (iret /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + end if + + list_pos = 1 + send_offset = 0 + recv_offset = 0 + do neighbor_idx = 1, n_neighbors + proc_to_comm = comm_list(list_pos + psb_proc_id_) + actual_recv_count = comm_list(list_pos + psb_n_elem_recv_) + actual_send_count = comm_list(list_pos + actual_recv_count + psb_n_elem_send_) + + this%peer_proc(neighbor_idx) = proc_to_comm + ! Swap: effective send = actual recv, effective recv = actual send + this%peer_send_counts(neighbor_idx) = actual_recv_count + this%peer_recv_counts(neighbor_idx) = actual_send_count + this%peer_send_displs(neighbor_idx) = send_offset + this%peer_recv_displs(neighbor_idx) = recv_offset + this%peer_mpi_rank(neighbor_idx) = peer_mpi_rank(neighbor_idx) + + ! peer_send_indexes from RECV area of comm_list (these are indices we gather for "sending") + if (actual_recv_count > 0) then + do item_idx = 1, actual_recv_count + this%peer_send_indexes(send_offset + item_idx) = comm_list(list_pos + psb_elem_recv_ + item_idx - 1) + end do + end if + + ! peer_recv_indexes from SEND area of comm_list (these are indices we scatter into) + if (actual_send_count > 0) then + do item_idx = 1, actual_send_count + this%peer_recv_indexes(recv_offset + item_idx) = comm_list(list_pos + actual_recv_count + psb_elem_send_ + item_idx - 1) + end do + end if + + send_offset = send_offset + actual_recv_count + recv_offset = recv_offset + actual_send_count + list_pos = list_pos + actual_recv_count + actual_send_count + 3 + end do + + do neighbor_idx = 1, n_neighbors + proc_to_comm = this%peer_proc(neighbor_idx) + if (proc_to_comm /= my_rank) then + prc_rank = this%peer_mpi_rank(neighbor_idx) + ! Tell peer: our effective-send (=actual recv) displacement and count, + ! our effective-recv (=actual send) displacement (offset past eff_send area). + local_meta = (/ this%peer_send_displs(neighbor_idx)+1, this%peer_send_counts(neighbor_idx), & + & this%peer_recv_displs(neighbor_idx)+1+eff_send, this%peer_recv_counts(neighbor_idx) /) + call mpi_sendrecv(local_meta, 4, psb_mpi_mpk_, prc_rank, psb_rma_meta_tag, & + & remote_meta, 4, psb_mpi_mpk_, prc_rank, psb_rma_meta_tag, icomm, p2pstat, iret) + if (iret /= mpi_success) then + info = psb_err_mpi_error_ + return + end if + this%peer_remote_send_displs(neighbor_idx) = remote_meta(1) + this%peer_remote_recv_displs(neighbor_idx) = remote_meta(3) + else + this%peer_remote_send_displs(neighbor_idx) = this%peer_send_displs(neighbor_idx)+1 + this%peer_remote_recv_displs(neighbor_idx) = this%peer_recv_displs(neighbor_idx)+1+eff_send + end if + end do + + if ((send_offset /= eff_send) .or. (recv_offset /= eff_recv)) then + info = psb_err_internal_error_ + return + end if + + this%layout_nnbr = n_neighbors + this%layout_send = eff_send + this%layout_recv = eff_recv + this%layout_ready = .true. + end subroutine psb_comm_rma_ini_memory_buffer_layout_tran + subroutine psb_comm_rma_set_swap_status(this, flag, info) class(psb_comm_rma_handle), intent(inout) :: this integer(psb_ipk_), intent(in) :: flag diff --git a/base/modules/comm/psb_c_comm_a_mod.f90 b/base/modules/comm/psb_c_comm_a_mod.f90 index 0fbcf01ec..c25270ecd 100644 --- a/base/modules/comm/psb_c_comm_a_mod.f90 +++ b/base/modules/comm/psb_c_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/comm/psb_c_comm_mod.f90 b/base/modules/comm/psb_c_comm_mod.f90 index 44126faae..584589b9c 100644 --- a/base/modules/comm/psb_c_comm_mod.f90 +++ b/base/modules/comm/psb_c_comm_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -40,7 +40,7 @@ module psb_c_comm_mod subroutine psb_covrl_vect(x,desc_a,info,update,mode) import implicit none - type(psb_c_vect_type), intent(inout) :: x + type(psb_c_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode @@ -49,9 +49,9 @@ module psb_c_comm_mod import implicit none type(psb_c_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_covrl_multivect end interface psb_ovrl @@ -59,7 +59,7 @@ module psb_c_comm_mod subroutine psb_chalo_vect(x,desc_a,info,tran,mode,data) import implicit none - type(psb_c_vect_type), intent(inout) :: x + type(psb_c_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: mode,data @@ -69,16 +69,16 @@ module psb_c_comm_mod import implicit none type(psb_c_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_chalo_multivect end interface psb_halo interface psb_scatter - subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) + subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) import implicit none type(psb_c_vect_type), intent(inout) :: locx diff --git a/base/modules/comm/psb_c_linmap_mod.f90 b/base/modules/comm/psb_c_linmap_mod.f90 index 4ccc8d55d..99957b00b 100644 --- a/base/modules/comm/psb_c_linmap_mod.f90 +++ b/base/modules/comm/psb_c_linmap_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -76,11 +76,11 @@ module psb_c_linmap_mod subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_c_vect_mod, only : psb_c_vect_type import :: psb_ipk_, psb_spk_, psb_clinmap_type - implicit none + implicit none class(psb_clinmap_type), intent(in) :: map complex(psb_spk_), intent(in) :: alpha,beta type(psb_c_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_c_map_U2V_v end interface @@ -99,11 +99,11 @@ module psb_c_linmap_mod subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_c_vect_mod, only : psb_c_vect_type import :: psb_ipk_, psb_spk_, psb_clinmap_type - implicit none + implicit none class(psb_clinmap_type), intent(in) :: map complex(psb_spk_), intent(in) :: alpha,beta type(psb_c_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_c_map_V2U_v end interface diff --git a/base/modules/comm/psb_comm_mod.f90 b/base/modules/comm/psb_comm_mod.f90 index 17cffe4cd..d9fabfa9e 100644 --- a/base/modules/comm/psb_comm_mod.f90 +++ b/base/modules/comm/psb_comm_mod.f90 @@ -45,4 +45,16 @@ module psb_comm_mod use psb_c_comm_mod use psb_z_comm_mod + ! Import scheme symbols and re-export them as public symbols from this module. + use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, & + & psb_comm_ineighbor_alltoallv_, psb_comm_persistent_ineighbor_alltoallv_, & + & psb_comm_rma_pull_, psb_comm_rma_push_, psb_comm_unknown_, & + & psb_comm_status_unknown_, psb_comm_status_start_, psb_comm_status_wait_, & + & psb_comm_status_sync_ + + public :: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, & + & psb_comm_persistent_ineighbor_alltoallv_, psb_comm_rma_pull_, psb_comm_rma_push_, & + & psb_comm_unknown_, psb_comm_status_unknown_, psb_comm_status_start_, & + & psb_comm_status_wait_, psb_comm_status_sync_ + end module psb_comm_mod diff --git a/base/modules/comm/psb_d_comm_a_mod.f90 b/base/modules/comm/psb_d_comm_a_mod.f90 index 0190225f8..aa3c6feb8 100644 --- a/base/modules/comm/psb_d_comm_a_mod.f90 +++ b/base/modules/comm/psb_d_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -36,11 +36,11 @@ module psb_d_comm_a_mod subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) import implicit none - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode end subroutine psb_dovrlm subroutine psb_dovrlv(x,desc_a,info,work,update,mode) import @@ -57,22 +57,22 @@ module psb_d_comm_a_mod subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) import implicit none - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran end subroutine psb_dhalom subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) import implicit none - real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_dhalov end interface psb_halo diff --git a/base/modules/comm/psb_d_comm_mod.f90 b/base/modules/comm/psb_d_comm_mod.f90 index 90cbfbc9d..51d2cb69f 100644 --- a/base/modules/comm/psb_d_comm_mod.f90 +++ b/base/modules/comm/psb_d_comm_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -40,18 +40,18 @@ module psb_d_comm_mod subroutine psb_dovrl_vect(x,desc_a,info,update,mode) import implicit none - type(psb_d_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_d_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_dovrl_vect subroutine psb_dovrl_multivect(x,desc_a,info,update,mode) import implicit none type(psb_d_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_dovrl_multivect end interface psb_ovrl @@ -59,20 +59,20 @@ module psb_d_comm_mod subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data) import implicit none - type(psb_d_vect_type), intent(inout) :: x + type(psb_d_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: tran integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_dhalo_vect subroutine psb_dhalo_multivect(x,desc_a,info,tran,mode,data) import implicit none type(psb_d_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: tran - integer(psb_ipk_), intent(in), optional :: mode,data + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_dhalo_multivect end interface psb_halo diff --git a/base/modules/comm/psb_d_linmap_mod.f90 b/base/modules/comm/psb_d_linmap_mod.f90 index 2bef33fd9..8463cfb39 100644 --- a/base/modules/comm/psb_d_linmap_mod.f90 +++ b/base/modules/comm/psb_d_linmap_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -76,11 +76,11 @@ module psb_d_linmap_mod subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_d_vect_mod, only : psb_d_vect_type import :: psb_ipk_, psb_dpk_, psb_dlinmap_type - implicit none + implicit none class(psb_dlinmap_type), intent(in) :: map real(psb_dpk_), intent(in) :: alpha,beta type(psb_d_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_d_map_U2V_v end interface @@ -99,11 +99,11 @@ module psb_d_linmap_mod subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_d_vect_mod, only : psb_d_vect_type import :: psb_ipk_, psb_dpk_, psb_dlinmap_type - implicit none + implicit none class(psb_dlinmap_type), intent(in) :: map real(psb_dpk_), intent(in) :: alpha,beta type(psb_d_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_d_map_V2U_v end interface diff --git a/base/modules/comm/psb_e_comm_a_mod.f90 b/base/modules/comm/psb_e_comm_a_mod.f90 index 0e57a4594..b9c9b1fe0 100644 --- a/base/modules/comm/psb_e_comm_a_mod.f90 +++ b/base/modules/comm/psb_e_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/comm/psb_i2_comm_a_mod.f90 b/base/modules/comm/psb_i2_comm_a_mod.f90 index 72cdf228b..7ac24f9d1 100644 --- a/base/modules/comm/psb_i2_comm_a_mod.f90 +++ b/base/modules/comm/psb_i2_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/comm/psb_i2_comm_mod.f90 b/base/modules/comm/psb_i2_comm_mod.f90 new file mode 100644 index 000000000..30af74391 --- /dev/null +++ b/base/modules/comm/psb_i2_comm_mod.f90 @@ -0,0 +1,113 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_i2_comm_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_, psb_i2pk_ + + use psb_i2_vect_mod, only : psb_i2_vect_type, psb_i2_base_vect_type + use psb_i2_multivect_mod, only : psb_i2_multivect_type, psb_i2_base_multivect_type + + interface psb_ovrl + subroutine psb_i2ovrl_vect(x,desc_a,info,update,mode) + import + implicit none + type(psb_i2_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_i2ovrl_vect + subroutine psb_i2ovrl_multivect(x,desc_a,info,update,mode) + import + implicit none + type(psb_i2_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_i2ovrl_multivect + end interface psb_ovrl + + interface psb_halo + subroutine psb_i2halo_vect(x,desc_a,info,tran,mode,data) + import + implicit none + type(psb_i2_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_i2halo_vect + subroutine psb_i2halo_multivect(x,desc_a,info,tran,mode,data) + import + implicit none + type(psb_i2_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_i2halo_multivect + end interface psb_halo + + + interface psb_scatter + subroutine psb_i2scatter_vect(globx, locx, desc_a, info, root, mold) + import + implicit none + type(psb_i2_vect_type), intent(inout) :: locx + integer(psb_i2pk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + class(psb_i2_base_vect_type), intent(in), optional :: mold + end subroutine psb_i2scatter_vect + end interface psb_scatter + + interface psb_gather + subroutine psb_i2gather_vect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_i2_vect_type), intent(inout) :: locx + integer(psb_i2pk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_i2gather_vect + subroutine psb_i2gather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_i2_multivect_type), intent(inout) :: locx + integer(psb_i2pk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_i2gather_multivect + end interface psb_gather + +end module psb_i2_comm_mod diff --git a/base/modules/comm/psb_i_comm_mod.f90 b/base/modules/comm/psb_i_comm_mod.f90 index a6f243278..781a37403 100644 --- a/base/modules/comm/psb_i_comm_mod.f90 +++ b/base/modules/comm/psb_i_comm_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -30,7 +30,7 @@ ! ! module psb_i_comm_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_, psb_i2pk_ use psb_i_vect_mod, only : psb_i_vect_type, psb_i_base_vect_type use psb_i_multivect_mod, only : psb_i_multivect_type, psb_i_base_multivect_type @@ -39,7 +39,7 @@ module psb_i_comm_mod subroutine psb_iovrl_vect(x,desc_a,info,update,mode) import implicit none - type(psb_i_vect_type), intent(inout) :: x + type(psb_i_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode @@ -48,9 +48,9 @@ module psb_i_comm_mod import implicit none type(psb_i_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_iovrl_multivect end interface psb_ovrl @@ -58,7 +58,7 @@ module psb_i_comm_mod subroutine psb_ihalo_vect(x,desc_a,info,tran,mode,data) import implicit none - type(psb_i_vect_type), intent(inout) :: x + type(psb_i_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: mode,data @@ -68,10 +68,10 @@ module psb_i_comm_mod import implicit none type(psb_i_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_ihalo_multivect end interface psb_halo diff --git a/base/modules/comm/psb_l_comm_mod.f90 b/base/modules/comm/psb_l_comm_mod.f90 index 0f55c7b10..aa70f622a 100644 --- a/base/modules/comm/psb_l_comm_mod.f90 +++ b/base/modules/comm/psb_l_comm_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -30,7 +30,7 @@ ! ! module psb_l_comm_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_, psb_i2pk_ use psb_l_vect_mod, only : psb_l_vect_type, psb_l_base_vect_type use psb_l_multivect_mod, only : psb_l_multivect_type, psb_l_base_multivect_type @@ -39,7 +39,7 @@ module psb_l_comm_mod subroutine psb_lovrl_vect(x,desc_a,info,update,mode) import implicit none - type(psb_l_vect_type), intent(inout) :: x + type(psb_l_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode @@ -48,9 +48,9 @@ module psb_l_comm_mod import implicit none type(psb_l_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_lovrl_multivect end interface psb_ovrl @@ -58,7 +58,7 @@ module psb_l_comm_mod subroutine psb_lhalo_vect(x,desc_a,info,tran,mode,data) import implicit none - type(psb_l_vect_type), intent(inout) :: x + type(psb_l_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: mode,data @@ -68,10 +68,10 @@ module psb_l_comm_mod import implicit none type(psb_l_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_lhalo_multivect end interface psb_halo diff --git a/base/modules/comm/psb_m_comm_a_mod.f90 b/base/modules/comm/psb_m_comm_a_mod.f90 index 105f14d7e..83a07e2d2 100644 --- a/base/modules/comm/psb_m_comm_a_mod.f90 +++ b/base/modules/comm/psb_m_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/comm/psb_s_comm_a_mod.f90 b/base/modules/comm/psb_s_comm_a_mod.f90 index 5ceaad8bf..8f1a88905 100644 --- a/base/modules/comm/psb_s_comm_a_mod.f90 +++ b/base/modules/comm/psb_s_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/comm/psb_s_comm_mod.f90 b/base/modules/comm/psb_s_comm_mod.f90 index 3430af4ce..ddb7232a5 100644 --- a/base/modules/comm/psb_s_comm_mod.f90 +++ b/base/modules/comm/psb_s_comm_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -40,7 +40,7 @@ module psb_s_comm_mod subroutine psb_sovrl_vect(x,desc_a,info,update,mode) import implicit none - type(psb_s_vect_type), intent(inout) :: x + type(psb_s_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode @@ -49,9 +49,9 @@ module psb_s_comm_mod import implicit none type(psb_s_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_sovrl_multivect end interface psb_ovrl @@ -59,7 +59,7 @@ module psb_s_comm_mod subroutine psb_shalo_vect(x,desc_a,info,tran,mode,data) import implicit none - type(psb_s_vect_type), intent(inout) :: x + type(psb_s_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: mode,data @@ -69,10 +69,10 @@ module psb_s_comm_mod import implicit none type(psb_s_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_shalo_multivect end interface psb_halo diff --git a/base/modules/comm/psb_s_linmap_mod.f90 b/base/modules/comm/psb_s_linmap_mod.f90 index 7e248df88..8659ae1ed 100644 --- a/base/modules/comm/psb_s_linmap_mod.f90 +++ b/base/modules/comm/psb_s_linmap_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -76,11 +76,11 @@ module psb_s_linmap_mod subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_s_vect_mod, only : psb_s_vect_type import :: psb_ipk_, psb_spk_, psb_slinmap_type - implicit none + implicit none class(psb_slinmap_type), intent(in) :: map real(psb_spk_), intent(in) :: alpha,beta type(psb_s_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_s_map_U2V_v end interface @@ -99,11 +99,11 @@ module psb_s_linmap_mod subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_s_vect_mod, only : psb_s_vect_type import :: psb_ipk_, psb_spk_, psb_slinmap_type - implicit none + implicit none class(psb_slinmap_type), intent(in) :: map real(psb_spk_), intent(in) :: alpha,beta type(psb_s_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_s_map_V2U_v end interface diff --git a/base/modules/comm/psb_z_comm_a_mod.f90 b/base/modules/comm/psb_z_comm_a_mod.f90 index 708efead7..478cc99a5 100644 --- a/base/modules/comm/psb_z_comm_a_mod.f90 +++ b/base/modules/comm/psb_z_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/comm/psb_z_comm_mod.f90 b/base/modules/comm/psb_z_comm_mod.f90 index cac47f452..b73f441a8 100644 --- a/base/modules/comm/psb_z_comm_mod.f90 +++ b/base/modules/comm/psb_z_comm_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -40,7 +40,7 @@ module psb_z_comm_mod subroutine psb_zovrl_vect(x,desc_a,info,update,mode) import implicit none - type(psb_z_vect_type), intent(inout) :: x + type(psb_z_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: update,mode @@ -49,9 +49,9 @@ module psb_z_comm_mod import implicit none type(psb_z_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: update,mode + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: update,mode end subroutine psb_zovrl_multivect end interface psb_ovrl @@ -59,7 +59,7 @@ module psb_z_comm_mod subroutine psb_zhalo_vect(x,desc_a,info,tran,mode,data) import implicit none - type(psb_z_vect_type), intent(inout) :: x + type(psb_z_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: mode,data @@ -69,10 +69,10 @@ module psb_z_comm_mod import implicit none type(psb_z_multivect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran end subroutine psb_zhalo_multivect end interface psb_halo diff --git a/base/modules/comm/psb_z_linmap_mod.f90 b/base/modules/comm/psb_z_linmap_mod.f90 index 24ec0db0c..fa0e7a734 100644 --- a/base/modules/comm/psb_z_linmap_mod.f90 +++ b/base/modules/comm/psb_z_linmap_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -76,11 +76,11 @@ module psb_z_linmap_mod subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_z_vect_mod, only : psb_z_vect_type import :: psb_ipk_, psb_dpk_, psb_zlinmap_type - implicit none + implicit none class(psb_zlinmap_type), intent(in) :: map complex(psb_dpk_), intent(in) :: alpha,beta type(psb_z_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_z_map_U2V_v end interface @@ -99,11 +99,11 @@ module psb_z_linmap_mod subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_z_vect_mod, only : psb_z_vect_type import :: psb_ipk_, psb_dpk_, psb_zlinmap_type - implicit none + implicit none class(psb_zlinmap_type), intent(in) :: map complex(psb_dpk_), intent(in) :: alpha,beta type(psb_z_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty end subroutine psb_z_map_V2U_v end interface diff --git a/base/modules/comm/psi_c_comm_a_mod.f90 b/base/modules/comm/psi_c_comm_a_mod.f90 index 97b5f9588..6676e36ba 100644 --- a/base/modules/comm/psi_c_comm_a_mod.f90 +++ b/base/modules/comm/psi_c_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,14 +31,16 @@ ! module psi_c_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_spk_, psb_i_base_vect_type interface psi_swapdata 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 - complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) complex(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -46,7 +48,8 @@ module psi_c_comm_a_mod 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 + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) complex(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -57,7 +60,8 @@ module psi_c_comm_a_mod 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_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_cswapidxm @@ -66,7 +70,8 @@ module psi_c_comm_a_mod 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_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_cswapidxv @@ -78,7 +83,8 @@ module psi_c_comm_a_mod integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) complex(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -86,7 +92,8 @@ module psi_c_comm_a_mod 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 + complex(psb_spk_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) complex(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -97,7 +104,8 @@ module psi_c_comm_a_mod 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_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:,:) complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ctranidxm @@ -106,7 +114,8 @@ module psi_c_comm_a_mod 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_), intent(in) :: beta + complex(psb_spk_), intent(inout) :: y(:) complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ctranidxv diff --git a/base/modules/comm/psi_c_comm_v_mod.f90 b/base/modules/comm/psi_c_comm_v_mod.f90 index 9c573e7cf..d52062a65 100644 --- a/base/modules/comm/psi_c_comm_v_mod.f90 +++ b/base/modules/comm/psi_c_comm_v_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,91 +31,132 @@ ! module psi_c_comm_v_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_spk_, psb_i_base_vect_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_spk_ use psb_c_base_vect_mod, only : psb_c_base_vect_type use psb_c_base_multivect_mod, only : psb_c_base_multivect_type interface psi_swapdata - module subroutine psi_cswapdata_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + module subroutine psi_cswapdata_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_vect - module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag + module subroutine psi_cswapdata_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_multivect_type), intent(inout) :: y - complex(psb_spk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_multivect + module subroutine psi_cswap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_cswap_vidx_vect + module subroutine psi_cswap_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_cswap_vidx_multivect end interface psi_swapdata interface psi_swaptran - module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + module subroutine psi_cswaptran_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_vect - module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_spk_), intent(in) :: beta + module subroutine psi_cswaptran_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_spk_), intent(in) :: beta class(psb_c_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_multivect + module subroutine psi_ctran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_ctran_vidx_vect + module subroutine psi_ctran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_ctran_vidx_multivect end interface psi_swaptran interface psi_ovrl_upd 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 + 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 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_covrl_upd_multivect end interface psi_ovrl_upd interface psi_ovrl_save module subroutine psi_covrl_save_vect(x,xs,desc_a,info) - class(psb_c_base_vect_type) :: x - complex(psb_spk_), allocatable :: xs(:) + 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 + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_save_vect 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_covrl_save_multivect end interface psi_ovrl_save interface psi_ovrl_restore 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 + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_restr_vect 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 - 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 end subroutine psi_covrl_restr_multivect end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_d_comm_a_mod.f90 b/base/modules/comm/psi_d_comm_a_mod.f90 index ca1aa9471..323c151c9 100644 --- a/base/modules/comm/psi_d_comm_a_mod.f90 +++ b/base/modules/comm/psi_d_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,48 +31,49 @@ ! module psi_d_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_dpk_, psb_i_base_vect_type interface psi_swapdata module subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) - integer(psb_ipk_), intent(in) :: flag integer(psb_mpk_), intent(in) :: n - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:,:) - type(psb_desc_type), target :: desc_a - real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:,:) + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatam module subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:) - type(psb_desc_type), target :: desc_a - real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:) + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatav module subroutine psi_dswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag integer(psb_mpk_), intent(in) :: n - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:,:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:,:) + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxm module subroutine psi_dswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: flag - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:) + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxv end interface psi_swapdata @@ -81,42 +82,42 @@ module psi_d_comm_a_mod 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 - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:,:) - type(psb_desc_type), target :: desc_a - real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data !! TODO: Is this used in the code? If not, remove it. + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:,:) + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data end subroutine psi_dswaptranm module subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:) - type(psb_desc_type), target :: desc_a - real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data !! TODO: Is this used in the code? If not, remove it. + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:) + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data end subroutine psi_dswaptranv module subroutine psi_dtranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_ipk_), intent(in) :: flag integer(psb_mpk_), intent(in) :: n - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:,:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:,:) + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxm module subroutine psi_dtranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) type(psb_ctxt_type), intent(in) :: ctxt integer(psb_ipk_), intent(in) :: flag - real(psb_dpk_),intent(in) :: beta - real(psb_dpk_),intent(inout) :: y(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), intent(inout) :: y(:) + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxv end interface psi_swaptran diff --git a/base/modules/comm/psi_d_comm_v_mod.f90 b/base/modules/comm/psi_d_comm_v_mod.f90 index fdc624b46..ee6ba89fa 100644 --- a/base/modules/comm/psi_d_comm_v_mod.f90 +++ b/base/modules/comm/psi_d_comm_v_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,101 +31,132 @@ ! module psi_d_comm_v_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_dpk_, psb_i_base_vect_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_dpk_ use psb_d_base_vect_mod, only : psb_d_base_vect_type use psb_d_base_multivect_mod, only : psb_d_base_multivect_type interface psi_swapdata - ! --------------------------------------------------------------- - ! Wrapper that calls different communications schemes depending on - ! swap_status variable using communication buff obtained from desc_a%get_list_p - ! --------------------------------------------------------------- module subroutine psi_dswapdata_vect(swap_status,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: swap_status - real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta class(psb_d_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_vect module subroutine psi_dswapdata_multivect(swap_status,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: swap_status - real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta class(psb_d_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_multivect + module subroutine psi_dswap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_dswap_vidx_vect + module subroutine psi_dswap_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_dswap_vidx_multivect end interface psi_swapdata interface psi_swaptran - ! --------------------------------------------------------------- - ! Upper call in order to populate idx using desc_a%get_list_p - ! and then call different communications schemes depending - ! on swap_status variable - ! --------------------------------------------------------------- module subroutine psi_dswaptran_vect(swap_status,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: swap_status - real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta class(psb_d_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_vect module subroutine psi_dswaptran_multivect(swap_status,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: swap_status - real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(in) :: swap_status + real(psb_dpk_), intent(in) :: beta class(psb_d_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_multivect - ! --------------------------------------------------------------- + module subroutine psi_dtran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_dtran_vidx_vect + module subroutine psi_dtran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_dtran_vidx_multivect end interface psi_swaptran interface psi_ovrl_upd 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 + 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 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_dovrl_upd_multivect end interface psi_ovrl_upd interface psi_ovrl_save module subroutine psi_dovrl_save_vect(x,xs,desc_a,info) - class(psb_d_base_vect_type) :: x - real(psb_dpk_), allocatable :: xs(:) + 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 + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_save_vect 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_dovrl_save_multivect end interface psi_ovrl_save interface psi_ovrl_restore 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 + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_restr_vect 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 - 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 end subroutine psi_dovrl_restr_multivect end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_e_comm_a_mod.f90 b/base/modules/comm/psi_e_comm_a_mod.f90 index 9e215e7cc..d87180d9e 100644 --- a/base/modules/comm/psi_e_comm_a_mod.f90 +++ b/base/modules/comm/psi_e_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,14 +31,16 @@ ! module psi_e_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_epk_, psb_i2pk_ interface psi_swapdata 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 - integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) integer(psb_epk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -46,7 +48,8 @@ module psi_e_comm_a_mod 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 + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) integer(psb_epk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -57,7 +60,8 @@ module psi_e_comm_a_mod 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_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_eswapidxm @@ -66,7 +70,8 @@ module psi_e_comm_a_mod 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_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_eswapidxv @@ -78,7 +83,8 @@ module psi_e_comm_a_mod integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) integer(psb_epk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -86,7 +92,8 @@ module psi_e_comm_a_mod 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 + integer(psb_epk_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) integer(psb_epk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -97,7 +104,8 @@ module psi_e_comm_a_mod 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_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:,:) integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_etranidxm @@ -106,7 +114,8 @@ module psi_e_comm_a_mod 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_), intent(in) :: beta + integer(psb_epk_), intent(inout) :: y(:) integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_etranidxv diff --git a/base/modules/comm/psi_i2_comm_a_mod.f90 b/base/modules/comm/psi_i2_comm_a_mod.f90 index d6c282f96..a12ffd8e1 100644 --- a/base/modules/comm/psi_i2_comm_a_mod.f90 +++ b/base/modules/comm/psi_i2_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,14 +31,16 @@ ! module psi_i2_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_epk_, psb_i2pk_ interface psi_swapdata 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 - integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) integer(psb_i2pk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -46,7 +48,8 @@ module psi_i2_comm_a_mod 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 + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) integer(psb_i2pk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -57,7 +60,8 @@ module psi_i2_comm_a_mod 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_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2swapidxm @@ -66,7 +70,8 @@ module psi_i2_comm_a_mod 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_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2swapidxv @@ -78,7 +83,8 @@ module psi_i2_comm_a_mod integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) integer(psb_i2pk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -86,7 +92,8 @@ module psi_i2_comm_a_mod 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 + integer(psb_i2pk_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) integer(psb_i2pk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -97,7 +104,8 @@ module psi_i2_comm_a_mod 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_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:,:) integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2tranidxm @@ -106,7 +114,8 @@ module psi_i2_comm_a_mod 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_), intent(in) :: beta + integer(psb_i2pk_), intent(inout) :: y(:) integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2tranidxv diff --git a/base/modules/comm/psi_i2_comm_v_mod.f90 b/base/modules/comm/psi_i2_comm_v_mod.f90 new file mode 100644 index 000000000..87f4a8b33 --- /dev/null +++ b/base/modules/comm/psi_i2_comm_v_mod.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i2_comm_v_mod + use psi_penv_mod, only : psb_ctxt_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_i2pk_ + use psb_i2_base_vect_mod, only : psb_i2_base_vect_type + use psb_i2_base_multivect_mod, only : psb_i2_base_multivect_type + + interface psi_swapdata + module subroutine psi_i2swapdata_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_i2pk_), intent(in) :: beta + class(psb_i2_base_vect_type), intent(inout) :: y + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + end subroutine psi_i2swapdata_vect + module subroutine psi_i2swapdata_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_i2pk_), intent(in) :: beta + class(psb_i2_base_multivect_type), intent(inout) :: y + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + end subroutine psi_i2swapdata_multivect + module subroutine psi_i2swap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i2_base_vect_type), intent(inout) :: y + integer(psb_i2pk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_i2swap_vidx_vect + module subroutine psi_i2swap_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i2_base_multivect_type), intent(inout) :: y + integer(psb_i2pk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_i2swap_vidx_multivect + end interface psi_swapdata + + + interface psi_swaptran + module subroutine psi_i2swaptran_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_i2pk_), intent(in) :: beta + class(psb_i2_base_vect_type), intent(inout) :: y + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + end subroutine psi_i2swaptran_vect + module subroutine psi_i2swaptran_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_i2pk_), intent(in) :: beta + class(psb_i2_base_multivect_type), intent(inout) :: y + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data + end subroutine psi_i2swaptran_multivect + module subroutine psi_i2tran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i2_base_vect_type), intent(inout) :: y + integer(psb_i2pk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_i2tran_vidx_vect + module subroutine psi_i2tran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i2_base_multivect_type), intent(inout) :: y + integer(psb_i2pk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_i2tran_vidx_multivect + end interface psi_swaptran + + interface psi_ovrl_upd + module subroutine psi_i2ovrl_upd_vect(x,desc_a,update,info) + class(psb_i2_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_i2ovrl_upd_vect + module subroutine psi_i2ovrl_upd_multivect(x,desc_a,update,info) + class(psb_i2_base_multivect_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_i2ovrl_upd_multivect + end interface psi_ovrl_upd + + interface psi_ovrl_save + module subroutine psi_i2ovrl_save_vect(x,xs,desc_a,info) + class(psb_i2_base_vect_type) :: x + integer(psb_i2pk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_save_vect + module subroutine psi_i2ovrl_save_multivect(x,xs,desc_a,info) + class(psb_i2_base_multivect_type) :: x + integer(psb_i2pk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_save_multivect + end interface psi_ovrl_save + + interface psi_ovrl_restore + module subroutine psi_i2ovrl_restr_vect(x,xs,desc_a,info) + class(psb_i2_base_vect_type) :: x + integer(psb_i2pk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_restr_vect + module subroutine psi_i2ovrl_restr_multivect(x,xs,desc_a,info) + class(psb_i2_base_multivect_type) :: x + integer(psb_i2pk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_restr_multivect + end interface psi_ovrl_restore + +end module psi_i2_comm_v_mod + diff --git a/base/modules/comm/psi_i_comm_a_mod.f90 b/base/modules/comm/psi_i_comm_a_mod.f90 new file mode 100644 index 000000000..920a23f9b --- /dev/null +++ b/base/modules/comm/psi_i_comm_a_mod.f90 @@ -0,0 +1,170 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i_comm_a_mod + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_epk_, psb_i2pk_ + + interface psi_swapdata + module subroutine psi_iswapdatam(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 + integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:,:) + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswapdatam + module subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:) + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswapdatav + module subroutine psi_iswapidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + 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_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:,:) + integer(psb_ipk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_iswapidxm + module subroutine psi_iswapidxv(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 + integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:) + integer(psb_ipk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_iswapidxv + end interface psi_swapdata + + + interface psi_swaptran + module subroutine psi_iswaptranm(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 + integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:,:) + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswaptranm + module subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:) + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswaptranv + module subroutine psi_itranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + 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_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:,:) + integer(psb_ipk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_itranidxm + module subroutine psi_itranidxv(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 + integer(psb_ipk_), intent(in) :: beta + integer(psb_ipk_), intent(inout) :: y(:) + integer(psb_ipk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_itranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + module subroutine psi_iovrl_updr1(x,desc_a,update,info) + integer(psb_ipk_), 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_iovrl_updr1 + module subroutine psi_iovrl_updr2(x,desc_a,update,info) + integer(psb_ipk_), 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_iovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + module subroutine psi_iovrl_saver1(x,xs,desc_a,info) + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_saver1 + module subroutine psi_iovrl_saver2(x,xs,desc_a,info) + integer(psb_ipk_), intent(inout) :: x(:,:) + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + module subroutine psi_iovrl_restrr1(x,xs,desc_a,info) + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_restrr1 + module subroutine psi_iovrl_restrr2(x,xs,desc_a,info) + integer(psb_ipk_), intent(inout) :: x(:,:) + integer(psb_ipk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_i_comm_a_mod + diff --git a/base/modules/comm/psi_i_comm_v_mod.f90 b/base/modules/comm/psi_i_comm_v_mod.f90 index b729ece67..73292eb1f 100644 --- a/base/modules/comm/psi_i_comm_v_mod.f90 +++ b/base/modules/comm/psi_i_comm_v_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,92 +31,132 @@ ! module psi_i_comm_v_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, & - & psb_lpk_, psb_epk_, psb_i2pk_ + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_ipk_ use psb_i_base_vect_mod, only : psb_i_base_vect_type use psb_i_base_multivect_mod, only : psb_i_base_multivect_type interface psi_swapdata - module subroutine psi_iswapdata_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + module subroutine psi_iswapdata_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_vect - module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + module subroutine psi_iswapdata_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_multivect + module subroutine psi_iswap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_iswap_vidx_vect + module subroutine psi_iswap_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_iswap_vidx_multivect end interface psi_swapdata interface psi_swaptran - module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + module subroutine psi_iswaptran_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_iswaptran_vect - module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(in) :: beta + module subroutine psi_iswaptran_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(in) :: beta class(psb_i_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_iswaptran_multivect + module subroutine psi_itran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_itran_vidx_vect + module subroutine psi_itran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_itran_vidx_multivect end interface psi_swaptran interface psi_ovrl_upd 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 + 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 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_iovrl_upd_multivect end interface psi_ovrl_upd interface psi_ovrl_save module subroutine psi_iovrl_save_vect(x,xs,desc_a,info) - class(psb_i_base_vect_type) :: x - integer(psb_ipk_), allocatable :: xs(:) + 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 + integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_save_vect 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_iovrl_save_multivect end interface psi_ovrl_save interface psi_ovrl_restore 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 + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_restr_vect 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 - 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 end subroutine psi_iovrl_restr_multivect end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_l_comm_a_mod.f90 b/base/modules/comm/psi_l_comm_a_mod.f90 new file mode 100644 index 000000000..600da3a18 --- /dev/null +++ b/base/modules/comm/psi_l_comm_a_mod.f90 @@ -0,0 +1,170 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_l_comm_a_mod + use psi_penv_mod, only : psb_ctxt_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_epk_, psb_i2pk_ + + interface psi_swapdata + module subroutine psi_lswapdatam(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 + integer(psb_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:,:) + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswapdatam + module subroutine psi_lswapdatav(flag,beta,y,desc_a,work,info,data) + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:) + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswapdatav + module subroutine psi_lswapidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + 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_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:,:) + integer(psb_lpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_lswapidxm + module subroutine psi_lswapidxv(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 + integer(psb_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:) + integer(psb_lpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_lswapidxv + end interface psi_swapdata + + + interface psi_swaptran + module subroutine psi_lswaptranm(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 + integer(psb_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:,:) + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswaptranm + module subroutine psi_lswaptranv(flag,beta,y,desc_a,work,info,data) + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:) + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswaptranv + module subroutine psi_ltranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + 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_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:,:) + integer(psb_lpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ltranidxm + module subroutine psi_ltranidxv(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 + integer(psb_lpk_), intent(in) :: beta + integer(psb_lpk_), intent(inout) :: y(:) + integer(psb_lpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ltranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + module subroutine psi_lovrl_updr1(x,desc_a,update,info) + integer(psb_lpk_), 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_lovrl_updr1 + module subroutine psi_lovrl_updr2(x,desc_a,update,info) + integer(psb_lpk_), 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_lovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + module subroutine psi_lovrl_saver1(x,xs,desc_a,info) + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_saver1 + module subroutine psi_lovrl_saver2(x,xs,desc_a,info) + integer(psb_lpk_), intent(inout) :: x(:,:) + integer(psb_lpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + module subroutine psi_lovrl_restrr1(x,xs,desc_a,info) + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_restrr1 + module subroutine psi_lovrl_restrr2(x,xs,desc_a,info) + integer(psb_lpk_), intent(inout) :: x(:,:) + integer(psb_lpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_l_comm_a_mod + diff --git a/base/modules/comm/psi_l_comm_v_mod.f90 b/base/modules/comm/psi_l_comm_v_mod.f90 index bcc33a2c8..bb29386df 100644 --- a/base/modules/comm/psi_l_comm_v_mod.f90 +++ b/base/modules/comm/psi_l_comm_v_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,93 +31,132 @@ ! module psi_l_comm_v_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, & - & psb_lpk_, psb_epk_, psb_i2pk_ - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_, psb_i_base_vect_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_ use psb_l_base_vect_mod, only : psb_l_base_vect_type use psb_l_base_multivect_mod, only : psb_l_base_multivect_type interface psi_swapdata - module subroutine psi_lswapdata_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + module subroutine psi_lswapdata_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_lswapdata_vect - module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + module subroutine psi_lswapdata_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_lswapdata_multivect + module subroutine psi_lswap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type), intent(inout) :: y + integer(psb_lpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_lswap_vidx_vect + module subroutine psi_lswap_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type), intent(inout) :: y + integer(psb_lpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_lswap_vidx_multivect end interface psi_swapdata interface psi_swaptran - module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + module subroutine psi_lswaptran_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_lswaptran_vect - module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_lpk_), intent(in) :: beta + module subroutine psi_lswaptran_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_lpk_), intent(in) :: beta class(psb_l_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_lswaptran_multivect + module subroutine psi_ltran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type), intent(inout) :: y + integer(psb_lpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_ltran_vidx_vect + module subroutine psi_ltran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type), intent(inout) :: y + integer(psb_lpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_ltran_vidx_multivect end interface psi_swaptran interface psi_ovrl_upd 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 + 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 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_lovrl_upd_multivect end interface psi_ovrl_upd interface psi_ovrl_save module subroutine psi_lovrl_save_vect(x,xs,desc_a,info) - class(psb_l_base_vect_type) :: x - integer(psb_lpk_), allocatable :: xs(:) + 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 + integer(psb_ipk_), intent(out) :: info end subroutine psi_lovrl_save_vect 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_lovrl_save_multivect end interface psi_ovrl_save interface psi_ovrl_restore 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 + integer(psb_lpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info end subroutine psi_lovrl_restr_vect 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 - 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 end subroutine psi_lovrl_restr_multivect end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_m_comm_a_mod.f90 b/base/modules/comm/psi_m_comm_a_mod.f90 index ac134e655..8ed2ac7e6 100644 --- a/base/modules/comm/psi_m_comm_a_mod.f90 +++ b/base/modules/comm/psi_m_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,14 +31,16 @@ ! module psi_m_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_epk_, psb_i2pk_ interface psi_swapdata 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 - integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) integer(psb_mpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -46,7 +48,8 @@ module psi_m_comm_a_mod 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 + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) integer(psb_mpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -57,7 +60,8 @@ module psi_m_comm_a_mod 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_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mswapidxm @@ -66,7 +70,8 @@ module psi_m_comm_a_mod 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_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mswapidxv @@ -78,7 +83,8 @@ module psi_m_comm_a_mod integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) integer(psb_mpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -86,7 +92,8 @@ module psi_m_comm_a_mod 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 + integer(psb_mpk_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) integer(psb_mpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -97,7 +104,8 @@ module psi_m_comm_a_mod 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_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:,:) integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mtranidxm @@ -106,7 +114,8 @@ module psi_m_comm_a_mod 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_), intent(in) :: beta + integer(psb_mpk_), intent(inout) :: y(:) integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mtranidxv diff --git a/base/modules/comm/psi_s_comm_a_mod.f90 b/base/modules/comm/psi_s_comm_a_mod.f90 index 3615bb6c0..f9a2fdc8a 100644 --- a/base/modules/comm/psi_s_comm_a_mod.f90 +++ b/base/modules/comm/psi_s_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,14 +31,16 @@ ! module psi_s_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_spk_, psb_i_base_vect_type interface psi_swapdata 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 - real(psb_spk_) :: y(:,:), beta + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) real(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -46,7 +48,8 @@ module psi_s_comm_a_mod 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 + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) real(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -57,7 +60,8 @@ module psi_s_comm_a_mod 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_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_sswapidxm @@ -66,7 +70,8 @@ module psi_s_comm_a_mod 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_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_sswapidxv @@ -78,7 +83,8 @@ module psi_s_comm_a_mod integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) real(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -86,7 +92,8 @@ module psi_s_comm_a_mod 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 + real(psb_spk_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) real(psb_spk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -97,7 +104,8 @@ module psi_s_comm_a_mod 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_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:,:) real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_stranidxm @@ -106,7 +114,8 @@ module psi_s_comm_a_mod 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_), intent(in) :: beta + real(psb_spk_), intent(inout) :: y(:) real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_stranidxv diff --git a/base/modules/comm/psi_s_comm_v_mod.f90 b/base/modules/comm/psi_s_comm_v_mod.f90 index 65cb904fc..67fbaa25e 100644 --- a/base/modules/comm/psi_s_comm_v_mod.f90 +++ b/base/modules/comm/psi_s_comm_v_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,92 +31,132 @@ ! module psi_s_comm_v_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_spk_, psb_i_base_vect_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_spk_ use psb_s_base_vect_mod, only : psb_s_base_vect_type use psb_s_base_multivect_mod, only : psb_s_base_multivect_type interface psi_swapdata - module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - real(psb_spk_), intent(in) :: beta + module subroutine psi_sswapdata_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta class(psb_s_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_vect - module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - real(psb_spk_), intent(in) :: beta + module subroutine psi_sswapdata_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta class(psb_s_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_multivect + module subroutine psi_sswap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: beta + 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,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: beta + 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,info,data) - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info + module subroutine psi_sswaptran_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta class(psb_s_base_vect_type), intent(inout) :: y - real(psb_spk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_vect - module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag + module subroutine psi_sswaptran_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + real(psb_spk_), intent(in) :: beta class(psb_s_base_multivect_type), intent(inout) :: y - real(psb_spk_), intent(in) :: beta - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_multivect + module subroutine psi_stran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_stran_vidx_vect + module subroutine psi_stran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_stran_vidx_multivect end interface psi_swaptran interface psi_ovrl_upd 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 + 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 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_sovrl_upd_multivect end interface psi_ovrl_upd interface psi_ovrl_save module subroutine psi_sovrl_save_vect(x,xs,desc_a,info) - class(psb_s_base_vect_type) :: x - real(psb_spk_), allocatable :: xs(:) + 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 + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_save_vect 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_sovrl_save_multivect end interface psi_ovrl_save interface psi_ovrl_restore 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 + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_restr_vect 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 - 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 end subroutine psi_sovrl_restr_multivect end interface psi_ovrl_restore diff --git a/base/modules/comm/psi_z_comm_a_mod.f90 b/base/modules/comm/psi_z_comm_a_mod.f90 index 28393467b..0203660d8 100644 --- a/base/modules/comm/psi_z_comm_a_mod.f90 +++ b/base/modules/comm/psi_z_comm_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,14 +31,16 @@ ! module psi_z_comm_a_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, & + & psb_dpk_, psb_i_base_vect_type interface psi_swapdata 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 - complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) complex(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -46,7 +48,8 @@ module psi_z_comm_a_mod 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 + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) complex(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -57,7 +60,8 @@ module psi_z_comm_a_mod 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_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_zswapidxm @@ -66,7 +70,8 @@ module psi_z_comm_a_mod 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_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_zswapidxv @@ -78,7 +83,8 @@ module psi_z_comm_a_mod integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) complex(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -86,7 +92,8 @@ module psi_z_comm_a_mod 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 + complex(psb_dpk_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) complex(psb_dpk_),target :: work(:) type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data @@ -97,7 +104,8 @@ module psi_z_comm_a_mod 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_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:,:) complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxm @@ -106,7 +114,8 @@ module psi_z_comm_a_mod 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_), intent(in) :: beta + complex(psb_dpk_), intent(inout) :: y(:) complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxv diff --git a/base/modules/comm/psi_z_comm_v_mod.f90 b/base/modules/comm/psi_z_comm_v_mod.f90 index 745d45318..e1eb6ed52 100644 --- a/base/modules/comm/psi_z_comm_v_mod.f90 +++ b/base/modules/comm/psi_z_comm_v_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,91 +31,132 @@ ! module psi_z_comm_v_mod use psi_penv_mod, only : psb_ctxt_type - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_dpk_, psb_i_base_vect_type + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_dpk_ use psb_z_base_vect_mod, only : psb_z_base_vect_type use psb_z_base_multivect_mod, only : psb_z_base_multivect_type interface psi_swapdata - module subroutine psi_zswapdata_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + module subroutine psi_zswapdata_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_vect - module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + module subroutine psi_zswapdata_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_multivect + module subroutine psi_zswap_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_zswap_vidx_vect + module subroutine psi_zswap_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_zswap_vidx_multivect end interface psi_swapdata interface psi_swaptran - module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + module subroutine psi_zswaptran_vect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_vect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_vect - module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,info,data) - integer(psb_ipk_), intent(in) :: flag - complex(psb_dpk_), intent(in) :: beta + module subroutine psi_zswaptran_multivect(swap_status,beta,y,desc_a,info,data) + integer(psb_ipk_), intent(in) :: swap_status + complex(psb_dpk_), intent(in) :: beta class(psb_z_base_multivect_type), intent(inout) :: y - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional :: data + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_multivect + module subroutine psi_ztran_vidx_vect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_ztran_vidx_vect + module subroutine psi_ztran_vidx_multivect(ctxt,swap_status,beta,y,idx,& + & totxch,totsnd,totrcv,info) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: swap_status + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: beta + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch, totsnd, totrcv + end subroutine psi_ztran_vidx_multivect end interface psi_swaptran interface psi_ovrl_upd 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 + 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 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_zovrl_upd_multivect end interface psi_ovrl_upd interface psi_ovrl_save module subroutine psi_zovrl_save_vect(x,xs,desc_a,info) - class(psb_z_base_vect_type) :: x - complex(psb_dpk_), allocatable :: xs(:) + 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 + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_save_vect 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 - integer(psb_ipk_), intent(out) :: info + 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 end subroutine psi_zovrl_save_multivect end interface psi_ovrl_save interface psi_ovrl_restore 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 + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_restr_vect 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 - 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 end subroutine psi_zovrl_restr_multivect end interface psi_ovrl_restore diff --git a/base/modules/penv/psi_c_collective_mod.F90 b/base/modules/penv/psi_c_collective_mod.F90 index 0e04fd5ed..dedd8503c 100644 --- a/base/modules/penv/psi_c_collective_mod.F90 +++ b/base/modules/penv/psi_c_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_c_p2p_mod.F90 b/base/modules/penv/psi_c_p2p_mod.F90 index 183584ff9..8a5f2c20b 100644 --- a/base/modules/penv/psi_c_p2p_mod.F90 +++ b/base/modules/penv/psi_c_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_d_collective_mod.F90 b/base/modules/penv/psi_d_collective_mod.F90 index bf66dc470..14e4f48a5 100644 --- a/base/modules/penv/psi_d_collective_mod.F90 +++ b/base/modules/penv/psi_d_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_d_p2p_mod.F90 b/base/modules/penv/psi_d_p2p_mod.F90 index 280f328de..99369d4a1 100644 --- a/base/modules/penv/psi_d_p2p_mod.F90 +++ b/base/modules/penv/psi_d_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_e_collective_mod.F90 b/base/modules/penv/psi_e_collective_mod.F90 index 15c69864f..63ad5627d 100644 --- a/base/modules/penv/psi_e_collective_mod.F90 +++ b/base/modules/penv/psi_e_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_e_p2p_mod.F90 b/base/modules/penv/psi_e_p2p_mod.F90 index f6c37d8a8..f3c4d2bac 100644 --- a/base/modules/penv/psi_e_p2p_mod.F90 +++ b/base/modules/penv/psi_e_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_i2_collective_mod.F90 b/base/modules/penv/psi_i2_collective_mod.F90 index 7ca2de155..cb2fe435c 100644 --- a/base/modules/penv/psi_i2_collective_mod.F90 +++ b/base/modules/penv/psi_i2_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_i2_p2p_mod.F90 b/base/modules/penv/psi_i2_p2p_mod.F90 index 4d2d33858..eb70385e5 100644 --- a/base/modules/penv/psi_i2_p2p_mod.F90 +++ b/base/modules/penv/psi_i2_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_m_collective_mod.F90 b/base/modules/penv/psi_m_collective_mod.F90 index 0e858c03a..8db430045 100644 --- a/base/modules/penv/psi_m_collective_mod.F90 +++ b/base/modules/penv/psi_m_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_m_p2p_mod.F90 b/base/modules/penv/psi_m_p2p_mod.F90 index 0132ce02c..1f1683a88 100644 --- a/base/modules/penv/psi_m_p2p_mod.F90 +++ b/base/modules/penv/psi_m_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_s_collective_mod.F90 b/base/modules/penv/psi_s_collective_mod.F90 index 9936395ad..809ca2865 100644 --- a/base/modules/penv/psi_s_collective_mod.F90 +++ b/base/modules/penv/psi_s_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_s_p2p_mod.F90 b/base/modules/penv/psi_s_p2p_mod.F90 index d8352bd5d..a1b70392d 100644 --- a/base/modules/penv/psi_s_p2p_mod.F90 +++ b/base/modules/penv/psi_s_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_z_collective_mod.F90 b/base/modules/penv/psi_z_collective_mod.F90 index de4e5bcc7..cbe434ac3 100644 --- a/base/modules/penv/psi_z_collective_mod.F90 +++ b/base/modules/penv/psi_z_collective_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/penv/psi_z_p2p_mod.F90 b/base/modules/penv/psi_z_p2p_mod.F90 index 6606d4ed1..c8ed01eb7 100644 --- a/base/modules/penv/psi_z_p2p_mod.F90 +++ b/base/modules/penv/psi_z_p2p_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index fba5fd0d7..df71bd95e 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -31,6 +31,7 @@ ! module psb_realloc_mod use psb_const_mod + use psb_i2_realloc_mod use psb_m_realloc_mod use psb_e_realloc_mod use psb_s_realloc_mod diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index e77a9325f..6b82493bc 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -424,14 +424,14 @@ module psb_c_psblas_mod & desc_a, info, trans,doswap) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type - type(psb_cspmat_type), intent(in) :: a - type(psb_c_vect_type), intent(inout) :: x - type(psb_c_vect_type), intent(inout) :: y - complex(psb_spk_), intent(in) :: alpha, beta - type(psb_desc_type), intent(in) :: desc_a - character, optional, intent(in) :: trans - logical, optional, intent(in) :: doswap - integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in) :: a + type(psb_c_vect_type), intent(inout) :: x + type(psb_c_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_desc_type), intent(in) :: desc_a + character, optional, intent(in) :: trans + logical, optional, intent(in) :: doswap + integer(psb_ipk_), intent(out) :: info end subroutine psb_cspmv_vect end interface diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index 095c46039..1d5558c7b 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index 330775c94..6be3aca2e 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index e9d03f371..1e65f3d44 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psi_c_mod.F90 b/base/modules/psi_c_mod.F90 index d59d26a21..9028315c3 100644 --- a/base/modules/psi_c_mod.F90 +++ b/base/modules/psi_c_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psi_d_mod.F90 b/base/modules/psi_d_mod.F90 index f39527f12..833e32fc8 100644 --- a/base/modules/psi_d_mod.F90 +++ b/base/modules/psi_d_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psi_i2_mod.F90 b/base/modules/psi_i2_mod.F90 new file mode 100644 index 000000000..031bcf208 --- /dev/null +++ b/base/modules/psi_i2_mod.F90 @@ -0,0 +1,44 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i2_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & + & psb_lpk_, psb_i2pk_ + use psi_m_comm_a_mod + use psi_e_comm_a_mod + use psi_i2_comm_a_mod + use psb_i2_base_vect_mod, only : psb_i2_base_vect_type + use psb_i2_base_multivect_mod, only : psb_i2_base_multivect_type + use psi_i2_comm_v_mod + +end module psi_i2_mod + diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 index 881ae078f..22df34627 100644 --- a/base/modules/psi_i_mod.F90 +++ b/base/modules/psi_i_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,9 +31,11 @@ ! module psi_i_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & + & psb_lpk_, psb_i2pk_ use psi_m_comm_a_mod use psi_e_comm_a_mod + use psi_i2_comm_a_mod use psb_i_base_vect_mod, only : psb_i_base_vect_type use psb_i_base_multivect_mod, only : psb_i_base_multivect_type use psi_i_comm_v_mod diff --git a/base/modules/psi_l_mod.F90 b/base/modules/psi_l_mod.F90 index 1ea56ad0a..6be25a134 100644 --- a/base/modules/psi_l_mod.F90 +++ b/base/modules/psi_l_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -31,9 +31,11 @@ ! module psi_l_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, & + & psb_lpk_, psb_i2pk_ use psi_m_comm_a_mod use psi_e_comm_a_mod + use psi_i2_comm_a_mod use psb_l_base_vect_mod, only : psb_l_base_vect_type use psb_l_base_multivect_mod, only : psb_l_base_multivect_type use psi_l_comm_v_mod diff --git a/base/modules/psi_s_mod.F90 b/base/modules/psi_s_mod.F90 index cac4d0f6d..b87cade1c 100644 --- a/base/modules/psi_s_mod.F90 +++ b/base/modules/psi_s_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/psi_z_mod.F90 b/base/modules/psi_z_mod.F90 index dc102323f..1ce783151 100644 --- a/base/modules/psi_z_mod.F90 +++ b/base/modules/psi_z_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/serial/psb_c_base_mat_mod.F90 b/base/modules/serial/psb_c_base_mat_mod.F90 index a5537034e..2e83ab4e5 100644 --- a/base/modules/serial/psb_c_base_mat_mod.F90 +++ b/base/modules/serial/psb_c_base_mat_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index dc16f63b2..b2106a545 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -33,7 +33,7 @@ ! package: psb_c_base_vect_mod ! ! This module contains the definition of the psb_c_base_vect type which -! is a container for dense vectors. +! is a container for dense vectors.\ ! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran @@ -47,9 +47,10 @@ module psb_c_base_vect_mod use psb_const_mod use psb_error_mod use psb_realloc_mod + use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_ + use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free use psb_i_base_vect_mod use psb_l_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_c_base_vect_type !! The psb_c_base_vect_type @@ -63,10 +64,10 @@ module psb_c_base_vect_mod !! type psb_c_base_vect_type !> Values. - complex(psb_spk_), allocatable :: v(:) - complex(psb_spk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + complex(psb_spk_), allocatable :: v(:) + complex(psb_spk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + !> vector bldstate: !! null: pristine; !! build: it's being filled with entries; @@ -75,12 +76,10 @@ module psb_c_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate = psb_vect_null_ - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs = 0 - integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -144,9 +143,7 @@ module psb_c_base_vect_mod procedure, nopass :: device_wait => c_base_device_wait procedure, pass(x) :: maybe_free_buffer => c_base_maybe_free_buffer procedure, pass(x) :: free_buffer => c_base_free_buffer - procedure, pass(x) :: new_comid => c_base_new_comid - procedure, pass(x) :: free_comid => c_base_free_comid - + ! ! Basic info procedure, pass(x) :: get_nrows => c_base_get_nrows @@ -161,6 +158,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: set_vect => c_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> c_base_get_entry + procedure, pass(x) :: set_entry=> c_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -245,10 +243,6 @@ module psb_c_base_vect_mod procedure, pass(z) :: addconst_v2 => c_base_addconst_v2 generic, public :: addconst => addconst_a2,addconst_v2 - ! Methods used to handle topology in neighbor_alltoallv communication scheme - procedure, pass(x) :: init_topology => c_base_init_topology - procedure, pass(x) :: free_topology => c_base_free_topology - end type psb_c_base_vect_type @@ -430,11 +424,12 @@ contains use psi_serial_mod use psb_realloc_mod implicit none - class(psb_c_base_vect_type), intent(out) :: x + class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: clear logical :: clear_ + info = 0 if (present(clear)) then clear_ = clear else @@ -824,13 +819,17 @@ contains use psb_realloc_mod implicit none class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%comm_handle)) then + call psb_comm_free(x%comm_handle, info_comm) + if (info_comm /= psb_success_) info = info_comm + end if if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') call x%set_null() @@ -876,24 +875,6 @@ contains & call x%free_buffer(info) end subroutine c_base_maybe_free_buffer - - ! - !> Function base_free_comid: - !! \memberof psb_c_base_vect_type - !! \brief Free aux MPI communication id buffer - !! - !! \param info return code - !! - ! - subroutine c_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine c_base_free_comid function c_base_get_ncfs(x) result(res) implicit none @@ -1282,15 +1263,33 @@ contains ! function c_base_get_entry(x, index) result(res) implicit none - class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function c_base_get_entry + subroutine c_base_set_entry(x, index, val) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine c_base_set_entry + ! ! Overwrite with absolute value ! @@ -2289,17 +2288,6 @@ contains call psb_realloc(n,x%combuf,info) end subroutine c_base_new_buffer - subroutine c_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine c_base_new_comid - - ! ! shortcut alpha=1 beta=0 ! @@ -2438,35 +2426,6 @@ contains if (x%is_dev()) call x%sync() call z%addconst(x%v,b,info) end subroutine c_base_addconst_v2 - - - ! -------------------------------------------------------------------- - ! Implementation of methods used for neighbor alltoallv communication - ! -------------------------------------------------------------------- - subroutine c_base_init_topology(x, halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: halo_index(:) - integer(psb_ipk_), intent(in) :: num_exchanges, total_send_elems, total_recv_elems - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%init(halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - - end subroutine c_base_init_topology - - subroutine c_base_free_topology(x, info) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%free(info) - - end subroutine c_base_free_topology - ! -------------------------------------------------------------------- end module psb_c_base_vect_mod @@ -2476,7 +2435,6 @@ module psb_c_base_multivect_mod use psb_error_mod use psb_realloc_mod use psb_c_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_c_base_vect_type !! The psb_c_base_vect_type @@ -2493,10 +2451,10 @@ module psb_c_base_multivect_mod type psb_c_base_multivect_type !> Values. - complex(psb_spk_), allocatable :: v(:,:) - complex(psb_spk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + complex(psb_spk_), allocatable :: v(:,:) + complex(psb_spk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + !> vector bldstate: !! null: pristine; !! build: it's being filled with entries; @@ -2509,8 +2467,6 @@ module psb_c_base_multivect_mod integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: ncfs = 0 integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology contains ! ! Constructors/allocators @@ -2618,8 +2574,6 @@ module psb_c_base_multivect_mod procedure, nopass :: device_wait => c_base_mlv_device_wait procedure, pass(x) :: maybe_free_buffer => c_base_mlv_maybe_free_buffer procedure, pass(x) :: free_buffer => c_base_mlv_free_buffer - procedure, pass(x) :: new_comid => c_base_mlv_new_comid - procedure, pass(x) :: free_comid => c_base_mlv_free_comid ! ! Gather/scatter. These are needed for MPI interfacing. @@ -2636,10 +2590,6 @@ module psb_c_base_multivect_mod procedure, pass(y) :: sctb_x => c_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => c_base_mlv_sctb_buf generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf - - ! Neighbor alltoallv communication topology handling - procedure, pass(x) :: init_topology => c_base_mlv_init_topology - procedure, pass(x) :: free_topology => c_base_mlv_free_topology end type psb_c_base_multivect_type interface psb_c_base_multivect @@ -2721,7 +2671,7 @@ contains logical, intent(in), optional :: scratch call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch) + call x%asb(m,n,info,scratch=scratch) end subroutine c_base_mlv_bld_n @@ -2773,6 +2723,7 @@ contains class(psb_c_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info + info = 0 if (allocated(x%v)) then call x%sync() x%v(:,:) = czero @@ -3001,23 +2952,26 @@ contains case(psb_dupl_err_) do i=1,ncfs if (any(vv(x%iv(i),:).ne.czero)) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') return else vv(x%iv(i),:) = x%v(i,:) end if end do case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() info =-7 end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < m) & + if ((x%get_nrows() < m).or.(x%get_ncols() c_vect_check_addr procedure, pass(x) :: get_entry => c_vect_get_entry + procedure, pass(x) :: set_entry => c_vect_set_entry procedure, pass(x) :: dot_v => c_vect_dot_v procedure, pass(x) :: dot_a => c_vect_dot_a @@ -855,13 +856,21 @@ contains function c_vect_get_entry(x,index) result(res) implicit none - class(psb_c_vect_type), intent(in) :: x + class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res - res = 0 + res = czero if (allocated(x%v)) res = x%v%get_entry(index) end function c_vect_get_entry + subroutine c_vect_set_entry(x,index,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine c_vect_set_entry + function c_vect_dot_v(n,x,y) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x, y @@ -1660,19 +1669,20 @@ contains end subroutine c_mvect_bld_x - subroutine c_mvect_bld_n(x,m,n,mold) + subroutine c_mvect_bld_n(x,m,n,mold,scratch) integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(out) :: x class(psb_c_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_) :: info - + logical, intent(in), optional :: scratch + info = psb_success_ if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) endif - if (info == psb_success_) call x%v%bld(m,n) + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) end subroutine c_mvect_bld_n @@ -2153,3 +2163,4 @@ contains !!$ end function c_mvect_asum end module psb_c_multivect_mod + diff --git a/base/modules/serial/psb_d_base_mat_mod.F90 b/base/modules/serial/psb_d_base_mat_mod.F90 index b2f49f2d2..24c2097f7 100644 --- a/base/modules/serial/psb_d_base_mat_mod.F90 +++ b/base/modules/serial/psb_d_base_mat_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index 8a303ba95..df7b45f80 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -33,7 +33,7 @@ ! package: psb_d_base_vect_mod ! ! This module contains the definition of the psb_d_base_vect type which -! is a container for dense vectors. +! is a container for dense vectors.\ ! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran @@ -47,11 +47,10 @@ module psb_d_base_vect_mod use psb_const_mod use psb_error_mod use psb_realloc_mod - use psb_i_base_vect_mod - use psb_l_base_vect_mod use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_ use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free - + use psb_i_base_vect_mod + use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_d_base_vect_type !! The psb_d_base_vect_type @@ -65,9 +64,8 @@ module psb_d_base_vect_mod !! type psb_d_base_vect_type !> Values. - real(psb_dpk_), allocatable :: v(:) - real(psb_dpk_), allocatable :: combuf(:) - ! Polymorphic communication handle stored at vector level. + real(psb_dpk_), allocatable :: v(:) + real(psb_dpk_), allocatable :: combuf(:) class(psb_comm_handle_type), allocatable :: comm_handle !> vector bldstate: @@ -78,10 +76,10 @@ module psb_d_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate = psb_vect_null_ - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs = 0 - integer(psb_ipk_), allocatable :: iv(:) + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -145,7 +143,7 @@ module psb_d_base_vect_mod procedure, nopass :: device_wait => d_base_device_wait procedure, pass(x) :: maybe_free_buffer => d_base_maybe_free_buffer procedure, pass(x) :: free_buffer => d_base_free_buffer - + ! ! Basic info procedure, pass(x) :: get_nrows => d_base_get_nrows @@ -160,6 +158,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: set_vect => d_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> d_base_get_entry + procedure, pass(x) :: set_entry=> d_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -175,7 +174,8 @@ module psb_d_base_vect_mod generic, public :: sct => sctb, sctb_x, sctb_buf procedure, pass(x) :: check_addr => d_base_check_addr - + + ! ! Dot product and AXPBY @@ -250,6 +250,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: minquotient_v => d_base_minquotient_v procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2 generic, public :: minquotient => minquotient_v, minquotient_a2 + end type psb_d_base_vect_type public :: psb_d_base_vect @@ -405,11 +406,6 @@ contains call psb_realloc(n,x%iv,info) call x%set_ncfs(0) end if - if (info == psb_success_) then - if (.not. allocated(x%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, x%comm_handle, info) - end if - end if end subroutine d_base_all @@ -428,9 +424,6 @@ contains integer(psb_ipk_), intent(out) :: info allocate(psb_d_base_vect_type :: y, stat=info) - if (info == psb_success_) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) - end if end subroutine d_base_mold @@ -438,11 +431,12 @@ contains use psi_serial_mod use psb_realloc_mod implicit none - class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: clear logical :: clear_ + info = 0 if (present(clear)) then clear_ = clear else @@ -455,11 +449,6 @@ contains call x%set_host() call x%set_upd() end if - if (info == psb_success_) then - if (.not. allocated(x%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, x%comm_handle, info) - end if - end if end subroutine d_base_reinit @@ -837,18 +826,17 @@ contains use psb_realloc_mod implicit none class(psb_d_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: info_comm + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) if ((info == 0).and.allocated(x%comm_handle)) then call psb_comm_free(x%comm_handle, info_comm) if (info_comm /= psb_success_) info = info_comm - end if + end if if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') call x%set_null() @@ -894,7 +882,7 @@ contains & call x%free_buffer(info) end subroutine d_base_maybe_free_buffer - + function d_base_get_ncfs(x) result(res) implicit none class(psb_d_base_vect_type), intent(in) :: x @@ -1098,25 +1086,12 @@ contains implicit none class(psb_d_base_vect_type), intent(in) :: x class(psb_d_base_vect_type), intent(out) :: y - integer(psb_ipk_) :: info - integer(psb_ipk_) :: swap_status if (allocated(x%v)) call y%bld(x%v) call y%set_state(x%get_state()) call y%set_dupl(x%get_dupl()) call y%set_ncfs(x%get_ncfs()) if (allocated(x%iv)) y%iv = x%iv - if (allocated(x%comm_handle)) then - call psb_comm_set(x%comm_handle%comm_type, y%comm_handle, info) - if (info /= psb_success_) return - y%comm_handle%id = x%comm_handle%id - call x%comm_handle%get_swap_status(swap_status, info) - if (info /= psb_success_) return - call y%comm_handle%set_swap_status(swap_status, info) - if (info /= psb_success_) return - else - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) - end if end subroutine d_base_cpy ! @@ -1295,15 +1270,33 @@ contains ! function d_base_get_entry(x, index) result(res) implicit none - class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function d_base_get_entry + subroutine d_base_set_entry(x, index, val) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine d_base_set_entry + ! ! Overwrite with absolute value ! @@ -2202,6 +2195,10 @@ contains res = min(res,abs(x%v(i))) end do #else + ! + ! From M&R&C: if the array is of size zero, MINVAL + ! returns the largest positive value + ! res = minval(x%v(1:n)) #endif end function d_base_min @@ -2366,56 +2363,6 @@ contains end subroutine d_base_device_wait - - subroutine d_base_init_comm(x, comm_handle, info) - ! `init_comm` is intentionally a configuration step. - ! It does not define the communication API surface itself; instead it: - ! 1) resets local communication buffers, - ! 2) ensures a handle exists with the requested concrete scheme, - ! recreating it only when needed (missing handle or type change), - ! 3) copies runtime state (`id`, swap status) from the input handle. - implicit none - class(psb_d_base_vect_type), intent(inout) :: x - class(psb_comm_handle_type), intent(in), pointer :: comm_handle - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: comm_type, swap_status - logical :: need_new_handle - - info = psb_success_ - - ! Reset/initialize communication related storage. Actual - ! topology/building is done lazily by neighbor_topology_init - if (allocated(x%combuf)) then - deallocate(x%combuf) - end if - - comm_type = psb_comm_isend_irecv_ - if (associated(comm_handle)) then - comm_type = comm_handle%comm_type - if (comm_type == psb_comm_unknown_) comm_type = psb_comm_isend_irecv_ - end if - - ! Recreate only when needed (missing handle or scheme change). - need_new_handle = .not. allocated(x%comm_handle) - if (.not. need_new_handle) then - need_new_handle = (x%comm_handle%comm_type /= comm_type) - end if - - if (need_new_handle) then - call psb_comm_set(comm_type, x%comm_handle, info) - if (info /= psb_success_) return - end if - - if (associated(comm_handle)) then - x%comm_handle%id = comm_handle%id - call comm_handle%get_swap_status(swap_status, info) - if (info /= psb_success_) return - call x%comm_handle%set_swap_status(swap_status, info) - if (info /= psb_success_) return - end if - - end subroutine d_base_init_comm - function d_base_use_buffer() result(res) logical :: res @@ -2432,7 +2379,6 @@ contains call psb_realloc(n,x%combuf,info) end subroutine d_base_new_buffer - ! ! shortcut alpha=1 beta=0 ! @@ -2663,7 +2609,6 @@ contains if (x%is_dev()) call x%sync() call z%addconst(x%v,b,info) end subroutine d_base_addconst_v2 - end module psb_d_base_vect_mod @@ -2673,7 +2618,6 @@ module psb_d_base_multivect_mod use psb_error_mod use psb_realloc_mod use psb_d_base_vect_mod - use psb_comm_schemes_mod, only: psb_comm_handle_type !> \namespace psb_base_mod \class psb_d_base_vect_type !! The psb_d_base_vect_type @@ -2690,9 +2634,9 @@ module psb_d_base_multivect_mod type psb_d_base_multivect_type !> Values. - real(psb_dpk_), allocatable :: v(:,:) - real(psb_dpk_), allocatable :: combuf(:) - ! neighbor-specific communication state removed; comm_handle owned below + real(psb_dpk_), allocatable :: v(:,:) + real(psb_dpk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle !> vector bldstate: !! null: pristine; @@ -2706,9 +2650,6 @@ module psb_d_base_multivect_mod integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: ncfs = 0 integer(psb_ipk_), allocatable :: iv(:) - - class(psb_comm_handle_type), allocatable :: comm_handle - contains ! ! Constructors/allocators @@ -2832,7 +2773,6 @@ module psb_d_base_multivect_mod procedure, pass(y) :: sctb_x => d_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => d_base_mlv_sctb_buf generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf - end type psb_d_base_multivect_type interface psb_d_base_multivect @@ -2914,7 +2854,7 @@ contains logical, intent(in), optional :: scratch call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch) + call x%asb(m,n,info,scratch=scratch) end subroutine d_base_mlv_bld_n @@ -2966,6 +2906,7 @@ contains class(psb_d_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info + info = 0 if (allocated(x%v)) then call x%sync() x%v(:,:) = dzero @@ -3194,23 +3135,26 @@ contains case(psb_dupl_err_) do i=1,ncfs if (any(vv(x%iv(i),:).ne.dzero)) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') return else vv(x%iv(i),:) = x%v(i,:) end if end do case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() info =-7 end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < m) & + if ((x%get_nrows() < m).or.(x%get_ncols() d_vect_check_addr procedure, pass(x) :: get_entry => d_vect_get_entry + procedure, pass(x) :: set_entry => d_vect_set_entry procedure, pass(x) :: dot_v => d_vect_dot_v procedure, pass(x) :: dot_a => d_vect_dot_a @@ -862,13 +863,21 @@ contains function d_vect_get_entry(x,index) result(res) implicit none - class(psb_d_vect_type), intent(in) :: x + class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res - res = 0 + res = dzero if (allocated(x%v)) res = x%v%get_entry(index) end function d_vect_get_entry + subroutine d_vect_set_entry(x,index,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine d_vect_set_entry + function d_vect_dot_v(n,x,y) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x, y @@ -1430,7 +1439,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = dzero + res = HUGE(done) end if end function d_vect_min @@ -1739,19 +1748,20 @@ contains end subroutine d_mvect_bld_x - subroutine d_mvect_bld_n(x,m,n,mold) + subroutine d_mvect_bld_n(x,m,n,mold,scratch) integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(out) :: x class(psb_d_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_) :: info - + logical, intent(in), optional :: scratch + info = psb_success_ if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) endif - if (info == psb_success_) call x%v%bld(m,n) + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) end subroutine d_mvect_bld_n @@ -2232,3 +2242,4 @@ contains !!$ end function d_mvect_asum end module psb_d_multivect_mod + diff --git a/base/modules/serial/psb_i2_base_vect_mod.F90 b/base/modules/serial/psb_i2_base_vect_mod.F90 new file mode 100644 index 000000000..01e665949 --- /dev/null +++ b/base/modules/serial/psb_i2_base_vect_mod.F90 @@ -0,0 +1,2526 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_i2_base_vect_mod +! +! This module contains the definition of the psb_i2_base_vect type which +! is a container for dense vectors.\ +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +module psb_i2_base_vect_mod + + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_ + use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free + use psb_i_base_vect_mod + + !> \namespace psb_base_mod \class psb_i2_base_vect_type + !! The psb_i2_base_vect_type + !! defines a middle level integer(psb_i2pk_) encapsulated dense vector. + !! The encapsulation is needed, in place of a simple array, to allow + !! for complicated situations, such as GPU programming, where the memory + !! area we are interested in is not easily accessible from the host/Fortran + !! side. It is also meant to be encapsulated in an outer type, to allow + !! runtime switching as per the STATE design pattern, similar to the + !! sparse matrix types. + !! + type psb_i2_base_vect_type + !> Values. + integer(psb_i2pk_), allocatable :: v(:) + integer(psb_i2pk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) + contains + ! + ! Constructors/allocators + ! + procedure, pass(x) :: bld_x => i2_base_bld_x + procedure, pass(x) :: bld_mn => i2_base_bld_mn + procedure, pass(x) :: bld_en => i2_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en + procedure, pass(x) :: all => i2_base_all + procedure, pass(x) :: mold => i2_base_mold + ! + ! Insert/set. Assembly and free. + ! Assembly does almost nothing here, but is important + ! in derived classes. + ! + procedure, pass(x) :: ins_a => i2_base_ins_a + procedure, pass(x) :: ins_v => i2_base_ins_v + generic, public :: ins => ins_a, ins_v + procedure, pass(x) :: zero => i2_base_zero + procedure, pass(x) :: asb_m => i2_base_asb_m + procedure, pass(x) :: asb_e => i2_base_asb_e + generic, public :: asb => asb_m, asb_e + procedure, pass(x) :: free => i2_base_free + procedure, pass(x) :: reinit => i2_base_reinit + procedure, pass(x) :: set_ncfs => i2_base_set_ncfs + procedure, pass(x) :: get_ncfs => i2_base_get_ncfs + procedure, pass(x) :: set_dupl => i2_base_set_dupl + procedure, pass(x) :: get_dupl => i2_base_get_dupl + procedure, pass(x) :: set_state => i2_base_set_state + procedure, pass(x) :: set_null => i2_base_set_null + procedure, pass(x) :: set_bld => i2_base_set_bld + procedure, pass(x) :: set_upd => i2_base_set_upd + procedure, pass(x) :: set_asb => i2_base_set_asb + procedure, pass(x) :: get_state => i2_base_get_state + procedure, pass(x) :: is_null => i2_base_is_null + procedure, pass(x) :: is_bld => i2_base_is_bld + procedure, pass(x) :: is_upd => i2_base_is_upd + procedure, pass(x) :: is_asb => i2_base_is_asb + procedure, pass(x) :: base_cpy => i2_base_cpy + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(x) :: sync => i2_base_sync + procedure, pass(x) :: is_host => i2_base_is_host + procedure, pass(x) :: is_dev => i2_base_is_dev + procedure, pass(x) :: is_sync => i2_base_is_sync + procedure, pass(x) :: set_host => i2_base_set_host + procedure, pass(x) :: set_dev => i2_base_set_dev + procedure, pass(x) :: set_sync => i2_base_set_sync + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => i2_base_use_buffer + procedure, pass(x) :: new_buffer => i2_base_new_buffer + procedure, nopass :: device_wait => i2_base_device_wait + procedure, pass(x) :: maybe_free_buffer => i2_base_maybe_free_buffer + procedure, pass(x) :: free_buffer => i2_base_free_buffer + + ! + ! Basic info + procedure, pass(x) :: get_nrows => i2_base_get_nrows + procedure, pass(x) :: sizeof => i2_base_sizeof + procedure, nopass :: get_fmt => i2_base_get_fmt + ! + ! Set/get data from/to an external array; also + ! overload assignment. + ! + procedure, pass(x) :: get_vect => i2_base_get_vect + procedure, pass(x) :: set_scal => i2_base_set_scal + procedure, pass(x) :: set_vect => i2_base_set_vect + generic, public :: set => set_vect, set_scal + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! + procedure, pass(x) :: gthab => i2_base_gthab + procedure, pass(x) :: gthzv => i2_base_gthzv + procedure, pass(x) :: gthzv_x => i2_base_gthzv_x + procedure, pass(x) :: gthzbuf => i2_base_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + procedure, pass(y) :: sctb => i2_base_sctb + procedure, pass(y) :: sctb_x => i2_base_sctb_x + procedure, pass(y) :: sctb_buf => i2_base_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf + + procedure, pass(x) :: check_addr => i2_base_check_addr + + + + + + + end type psb_i2_base_vect_type + + public :: psb_i2_base_vect + private :: constructor, size_const + interface psb_i2_base_vect + module procedure constructor, size_const + end interface psb_i2_base_vect + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_i2pk_) :: x(:) + type(psb_i2_base_vect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_i2_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const + + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_i2_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + subroutine i2_base_bld_x(x,this,scratch) + use psb_realloc_mod + implicit none + integer(psb_i2pk_), intent(in) :: this(:) + class(psb_i2_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + integer(psb_ipk_) :: i + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if +#if defined (PSB_OPENMP) + !$omp parallel do private(i) + do i = 1, size(this) + x%v(i) = this(i) + end do +#else + x%v(:) = this(:) +#endif + end subroutine i2_base_bld_x + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_i2_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine i2_base_bld_mn(x,n,scratch) + use psb_realloc_mod + implicit none + integer(psb_mpk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine i2_base_bld_mn + + !> Function bld_en: + !! \memberof psb_i2_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine i2_base_bld_en(x,n,scratch) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + call psb_realloc(n,x%v,info) + call x%asb(n,info,scratch=scratch_) + + end subroutine i2_base_bld_en + + !> Function base_all: + !! \memberof psb_i2_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + subroutine i2_base_all(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine i2_base_all + + !> Function base_mold: + !! \memberof psb_i2_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + subroutine i2_base_mold(x, y, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + class(psb_i2_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_i2_base_vect_type :: y, stat=info) + + end subroutine i2_base_mold + + subroutine i2_base_reinit(x, info,clear) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + logical :: clear_ + + info = 0 + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + if (clear_) x%v(:) = i2zero + call x%set_host() + call x%set_upd() + end if + + end subroutine i2_base_reinit + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_i2_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + subroutine i2_base_ins_a(n,irl,val,dupl,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_ensure_size(isz,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k) = val(i) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine i2_base_ins_a + + subroutine i2_base_ins_v(n,irl,val,dupl,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl, maxr + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_i2_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,maxr,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine i2_base_ins_v + + + ! + !> Function base_zero + !! \memberof psb_i2_base_vect_type + !! \brief Zero out contents + !! + ! + subroutine i2_base_zero(x) + use psi_serial_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) then + !$omp workshare + x%v(:)=i2zero + !$omp end workshare + end if + call x%set_host() + end subroutine i2_base_zero + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_i2_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine i2_base_asb_m(n, x, info, scratch) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_mpk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_i2pk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(n,vv,info) + vv(:) = i2zero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (vv(x%iv(i)).ne. i2zero) then + call psb_errpush(psb_err_duplicate_coo,'vect-asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine i2_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_i2_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine i2_base_asb_e(n, x, info, scratch) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_i2pk_), allocatable :: vv(:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb unhandled') + if (x%is_bld()) then + call psb_realloc(n,vv,info) + vv(:) = i2zero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = vv(x%iv(i)) + x%v(i) + end do + case(psb_dupl_ovwrt_) + do i=1,x%get_ncfs() + vv(x%iv(i)) = x%v(i) + end do + case(psb_dupl_err_) + do i=1,x%get_ncfs() + if (vv(x%iv(i)).ne. i2zero) then + call psb_errpush(psb_err_duplicate_coo,'vect_asb') + return + else + vv(x%iv(i)) = x%v(i) + end if + end do + case default + write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + else + info = psb_err_invalid_vect_state_ + call psb_errpush(info,'vect_asb') + end if + else + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + end if + call x%set_host() + call x%set_asb() + call x%sync() + end subroutine i2_base_asb_e + + ! + !> Function base_free: + !! \memberof psb_i2_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + subroutine i2_base_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%comm_handle)) then + call psb_comm_free(x%comm_handle, info_comm) + if (info_comm /= psb_success_) info = info_comm + end if + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + call x%set_null() + end subroutine i2_base_free + + ! + !> Function base_free_buffer: + !! \memberof psb_i2_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + subroutine i2_base_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine i2_base_free_buffer + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_i2_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + subroutine i2_base_maybe_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine i2_base_maybe_free_buffer + + function i2_base_get_ncfs(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function i2_base_get_ncfs + + function i2_base_get_dupl(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i2_base_get_dupl + + function i2_base_get_state(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function i2_base_get_state + + function i2_base_is_null(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function i2_base_is_null + + function i2_base_is_bld(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function i2_base_is_bld + + function i2_base_is_upd(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function i2_base_is_upd + + function i2_base_is_asb(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function i2_base_is_asb + + subroutine i2_base_set_ncfs(n,x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine i2_base_set_ncfs + + subroutine i2_base_set_dupl(n,x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine i2_base_set_dupl + + subroutine i2_base_set_state(n,x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine i2_base_set_state + + subroutine i2_base_set_null(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine i2_base_set_null + + subroutine i2_base_set_bld(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine i2_base_set_bld + + subroutine i2_base_set_upd(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine i2_base_set_upd + + subroutine i2_base_set_asb(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine i2_base_set_asb + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_i2_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + subroutine i2_base_sync(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + end subroutine i2_base_sync + + ! + !> Function base_set_host: + !! \memberof psb_i2_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + subroutine i2_base_set_host(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + end subroutine i2_base_set_host + + ! + !> Function base_set_dev: + !! \memberof psb_i2_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + subroutine i2_base_set_dev(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + end subroutine i2_base_set_dev + + ! + !> Function base_set_sync: + !! \memberof psb_i2_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + subroutine i2_base_set_sync(x) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + + end subroutine i2_base_set_sync + + ! + !> Function base_is_dev: + !! \memberof psb_i2_base_vect_type + !! \brief Is vector on external device . + !! + ! + function i2_base_is_dev(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function i2_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_i2_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + function i2_base_is_host(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function i2_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_i2_base_vect_type + !! \brief Is vector on sync . + !! + ! + function i2_base_is_sync(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function i2_base_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine i2_base_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + class(psb_i2_base_vect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine i2_base_cpy + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_i2_base_vect_type + !! \brief Number of entries + !! + ! + function i2_base_get_nrows(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function i2_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_i2_base_vect_type + !! \brief Size in bytes + !! + ! + function i2_base_sizeof(x) result(res) + implicit none + class(psb_i2_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_i2p) * x%get_nrows() + + end function i2_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_i2_base_vect_type + !! \brief Format + !! + ! + function i2_base_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'BASE' + end function i2_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_i2_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + function i2_base_get_vect(x,n) result(res) + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz, i + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + if (.false.) then + res(1:isz) = x%v(1:isz) + else + !$omp parallel do private(i) + do i=1, isz + res(i) = x%v(i) + end do + end if + + end function i2_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_i2_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + subroutine i2_base_set_scal(x,val,first,last) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val + end do +#else + x%v(first_:last_) = val +#endif + call x%set_host() + + end subroutine i2_base_set_scal + + + ! + !> Function base_set_vect + !! \memberof psb_i2_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + subroutine i2_base_set_vect(x,val,first,last) + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: first_, last_, i, info + + if (.not.allocated(x%v)) then + call psb_realloc(size(val),x%v,info) + end if + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + +#if defined(PSB_OPENMP) + !$omp parallel do private(i) + do i = first_, last_ + x%v(i) = val(i-first_+1) + end do +#else + x%v(first_:last_) = val(1:last_-first_+1) +#endif + call x%set_host() + + end subroutine i2_base_set_vect + + subroutine i2_base_check_addr(x) + class(psb_i2_base_vect_type), intent(inout) :: x + + write(0,*) 'Check addr: base version, do nothing' + + end subroutine i2_base_check_addr + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_i2_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + subroutine i2_base_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine i2_base_gthab + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_i2_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i2_base_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine i2_base_gthzv_x + + ! + ! New comm internals impl. + ! + subroutine i2_base_gthzbuf(i,n,idx,x) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i + integer(psb_mpk_) :: n + class(psb_i_base_vect_type) :: idx + class(psb_i2_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine i2_base_gthzbuf + ! + !> Function base_device_wait: + !! \memberof psb_i2_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine i2_base_device_wait() + implicit none + + end subroutine i2_base_device_wait + + function i2_base_use_buffer() result(res) + logical :: res + + res = .true. + end function i2_base_use_buffer + + subroutine i2_base_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_i2_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine i2_base_new_buffer + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_i2_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i2_base_gthzv(n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine i2_base_gthzv + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_i2_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + subroutine i2_base_sctb(n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine i2_base_sctb + + subroutine i2_base_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine i2_base_sctb_x + + subroutine i2_base_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta + class(psb_i2_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine i2_base_sctb_buf + + +end module psb_i2_base_vect_mod + + +module psb_i2_base_multivect_mod + + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_i2_base_vect_mod + + !> \namespace psb_base_mod \class psb_i2_base_vect_type + !! The psb_i2_base_vect_type + !! defines a middle level integer(psb_ipk_) encapsulated dense vector. + !! The encapsulation is needed, in place of a simple array, to allow + !! for complicated situations, such as GPU programming, where the memory + !! area we are interested in is not easily accessible from the host/Fortran + !! side. It is also meant to be encapsulated in an outer type, to allow + !! runtime switching as per the STATE design pattern, similar to the + !! sparse matrix types. + !! + private + public :: psb_i2_base_multivect, psb_i2_base_multivect_type + + type psb_i2_base_multivect_type + !> Values. + integer(psb_i2pk_), allocatable :: v(:,:) + integer(psb_i2pk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + + !> vector bldstate: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_vect_mod. + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) + contains + ! + ! Constructors/allocators + ! + procedure, pass(x) :: bld_x => i2_base_mlv_bld_x + procedure, pass(x) :: bld_n => i2_base_mlv_bld_n + generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: all => i2_base_mlv_all + procedure, pass(x) :: mold => i2_base_mlv_mold + ! + ! Insert/set. Assembly and free. + ! Assembly does almost nothing here, but is important + ! in derived classes. + ! + procedure, pass(x) :: ins => i2_base_mlv_ins + procedure, pass(x) :: zero => i2_base_mlv_zero + procedure, pass(x) :: asb => i2_base_mlv_asb + procedure, pass(x) :: free => i2_base_mlv_free + procedure, pass(x) :: reinit => i2_base_mlv_reinit + procedure, pass(x) :: set_ncfs => i2_base_mlv_set_ncfs + procedure, pass(x) :: get_ncfs => i2_base_mlv_get_ncfs + procedure, pass(x) :: set_dupl => i2_base_mlv_set_dupl + procedure, pass(x) :: get_dupl => i2_base_mlv_get_dupl + procedure, pass(x) :: set_state => i2_base_mlv_set_state + procedure, pass(x) :: set_null => i2_base_mlv_set_null + procedure, pass(x) :: set_bld => i2_base_mlv_set_bld + procedure, pass(x) :: set_upd => i2_base_mlv_set_upd + procedure, pass(x) :: set_asb => i2_base_mlv_set_asb + procedure, pass(x) :: get_state => i2_base_mlv_get_state + procedure, pass(x) :: is_null => i2_base_mlv_is_null + procedure, pass(x) :: is_bld => i2_base_mlv_is_bld + procedure, pass(x) :: is_upd => i2_base_mlv_is_upd + procedure, pass(x) :: is_asb => i2_base_mlv_is_asb + procedure, pass(x) :: base_cpy => i2_base_mlv_cpy + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(x) :: sync => i2_base_mlv_sync + procedure, pass(x) :: is_host => i2_base_mlv_is_host + procedure, pass(x) :: is_dev => i2_base_mlv_is_dev + procedure, pass(x) :: is_sync => i2_base_mlv_is_sync + procedure, pass(x) :: set_host => i2_base_mlv_set_host + procedure, pass(x) :: set_dev => i2_base_mlv_set_dev + procedure, pass(x) :: set_sync => i2_base_mlv_set_sync + + ! + ! Basic info + procedure, pass(x) :: get_nrows => i2_base_mlv_get_nrows + procedure, pass(x) :: get_ncols => i2_base_mlv_get_ncols + procedure, pass(x) :: sizeof => i2_base_mlv_sizeof + procedure, nopass :: get_fmt => i2_base_mlv_get_fmt + ! + ! Set/get data from/to an external array; also + ! overload assignment. + ! + procedure, pass(x) :: get_vect => i2_base_mlv_get_vect + procedure, pass(x) :: set_scal => i2_base_mlv_set_scal + procedure, pass(x) :: set_vect => i2_base_mlv_set_vect + generic, public :: set => set_vect, set_scal + + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => i2_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => i2_base_mlv_new_buffer + procedure, nopass :: device_wait => i2_base_mlv_device_wait + procedure, pass(x) :: maybe_free_buffer => i2_base_mlv_maybe_free_buffer + procedure, pass(x) :: free_buffer => i2_base_mlv_free_buffer + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! + procedure, pass(x) :: gthab => i2_base_mlv_gthab + procedure, pass(x) :: gthzv => i2_base_mlv_gthzv + procedure, pass(x) :: gthzm => i2_base_mlv_gthzm + procedure, pass(x) :: gthzv_x => i2_base_mlv_gthzv_x + procedure, pass(x) :: gthzbuf => i2_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf + procedure, pass(y) :: sctb => i2_base_mlv_sctb + procedure, pass(y) :: sctbr2 => i2_base_mlv_sctbr2 + procedure, pass(y) :: sctb_x => i2_base_mlv_sctb_x + procedure, pass(y) :: sctb_buf => i2_base_mlv_sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf + end type psb_i2_base_multivect_type + + interface psb_i2_base_multivect + module procedure constructor, size_const + end interface psb_i2_base_multivect + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_i2pk_) :: x(:,:) + type(psb_i2_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),& + & size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_i2_base_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(m,n,info) + + end function size_const + + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_i2_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + subroutine i2_base_mlv_bld_x(x,this) + use psb_realloc_mod + integer(psb_i2pk_), intent(in) :: this(:,:) + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine i2_base_mlv_bld_x + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_i2_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine i2_base_mlv_bld_n(x,m,n,scratch) + use psb_realloc_mod + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info,scratch=scratch) + + end subroutine i2_base_mlv_bld_n + + !> Function base_mlv_all: + !! \memberof psb_i2_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + subroutine i2_base_mlv_all(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + if (try_newins) then + call psb_realloc(n,x%iv,info) + call x%set_ncfs(0) + end if + + end subroutine i2_base_mlv_all + + !> Function base_mlv_mold: + !! \memberof psb_i2_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + subroutine i2_base_mlv_mold(x, y, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + class(psb_i2_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_i2_base_multivect_type :: y, stat=info) + + end subroutine i2_base_mlv_mold + + subroutine i2_base_mlv_reinit(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%sync() + x%v(:,:) = i2zero + call x%set_host() + call x%set_upd() + end if + + end subroutine i2_base_mlv_reinit + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_i2_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + subroutine i2_base_mlv_ins(n,irl,val,dupl,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz, nc, dupl_, ncfs_, k + + info = 0 + if (psb_errstatus_fatal()) return + + if (try_newins) then + if (x%is_bld()) then + nc = size(x%v,2) + ncfs_ = x%get_ncfs() + isz = ncfs_ + n + call psb_realloc(isz,nc,x%v,info) + call psb_ensure_size(isz,x%iv,info) + k = ncfs_ + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + k = k + 1 + ! this row belongs to me + ! copy i-th row of block val in x + x%v(k,:) = val(i,:) + x%iv(k) = irl(i) + end if + enddo + call x%set_ncfs(k) + + else if (x%is_upd()) then + + dupl_ = x%get_dupl() + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= maxr)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + else + info = psb_err_invalid_vect_state_ + end if + else + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + nc = size(x%v,2) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine i2_base_mlv_ins + + ! + !> Function base_mlv_zero + !! \memberof psb_i2_base_multivect_type + !! \brief Zero out contents + !! + ! + subroutine i2_base_mlv_zero(x) + use psi_serial_mod + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=i2zero + call x%set_host() + + end subroutine i2_base_mlv_zero + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_i2_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine i2_base_mlv_asb(m,n, x, info, scratch) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: i, ncfs, xvsz + integer(psb_i2pk_), allocatable :: vv(:,:) + + info = 0 + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + if (try_newins) then + if (x%is_bld()) then + ncfs = x%get_ncfs() + xvsz = psb_size(x%v) + call psb_realloc(m,n,vv,info) + vv(:,:) = i2zero + select case(x%get_dupl()) + case(psb_dupl_add_) + do i=1,ncfs + vv(x%iv(i),:) = vv(x%iv(i),:) + x%v(i,:) + end do + case(psb_dupl_ovwrt_) + do i=1,ncfs + vv(x%iv(i),:) = x%v(i,:) + end do + case(psb_dupl_err_) + do i=1,ncfs + if (any(vv(x%iv(i),:).ne.i2zero)) then + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') + return + else + vv(x%iv(i),:) = x%v(i,:) + end if + end do + case default + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() + info =-7 + end select + call psb_move_alloc(vv,x%v,info) + if (allocated(x%iv)) deallocate(x%iv,stat=info) + else if (x%is_upd().or.x%is_asb().or.scratch_) then + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_i2_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + subroutine i2_base_mlv_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine i2_base_mlv_free + + function i2_base_mlv_get_ncfs(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%ncfs + end function i2_base_mlv_get_ncfs + + function i2_base_mlv_get_dupl(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i2_base_mlv_get_dupl + + function i2_base_mlv_get_state(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%bldstate + end function i2_base_mlv_get_state + + function i2_base_mlv_is_null(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_null_) + end function i2_base_mlv_is_null + + function i2_base_mlv_is_bld(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_bld_) + end function i2_base_mlv_is_bld + + function i2_base_mlv_is_upd(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_upd_) + end function i2_base_mlv_is_upd + + function i2_base_mlv_is_asb(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + res = (x%bldstate == psb_vect_asb_) + end function i2_base_mlv_is_asb + + subroutine i2_base_mlv_set_ncfs(n,x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%ncfs = n + end subroutine i2_base_mlv_set_ncfs + + subroutine i2_base_mlv_set_dupl(n,x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%dupl = n + end subroutine i2_base_mlv_set_dupl + + subroutine i2_base_mlv_set_state(n,x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + x%bldstate = n + end subroutine i2_base_mlv_set_state + + subroutine i2_base_mlv_set_null(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_null_ + end subroutine i2_base_mlv_set_null + + subroutine i2_base_mlv_set_bld(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_bld_ + end subroutine i2_base_mlv_set_bld + + subroutine i2_base_mlv_set_upd(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_upd_ + end subroutine i2_base_mlv_set_upd + + subroutine i2_base_mlv_set_asb(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + x%bldstate = psb_vect_asb_ + end subroutine i2_base_mlv_set_asb + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_i2_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + subroutine i2_base_mlv_sync(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + end subroutine i2_base_mlv_sync + + ! + !> Function base_mlv_set_host: + !! \memberof psb_i2_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + subroutine i2_base_mlv_set_host(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + end subroutine i2_base_mlv_set_host + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_i2_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + subroutine i2_base_mlv_set_dev(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + end subroutine i2_base_mlv_set_dev + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_i2_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + subroutine i2_base_mlv_set_sync(x) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + + end subroutine i2_base_mlv_set_sync + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_i2_base_multivect_type + !! \brief Is vector on external device . + !! + ! + function i2_base_mlv_is_dev(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function i2_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_i2_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + function i2_base_mlv_is_host(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function i2_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_i2_base_multivect_type + !! \brief Is vector on sync . + !! + ! + function i2_base_mlv_is_sync(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function i2_base_mlv_is_sync + + !> Function base_cpy: + !! \memberof psb_d_base_vect_type + !! \brief base_cpy: copy base contents + !! \param y returned variable + !! + subroutine i2_base_mlv_cpy(x, y) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + class(psb_i2_base_multivect_type), intent(out) :: y + + if (allocated(x%v)) call y%bld(x%v) + call y%set_state(x%get_state()) + call y%set_dupl(x%get_dupl()) + call y%set_ncfs(x%get_ncfs()) + if (allocated(x%iv)) y%iv = x%iv + end subroutine i2_base_mlv_cpy + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_i2_base_multivect_type + !! \brief Number of entries + !! + ! + function i2_base_mlv_get_nrows(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function i2_base_mlv_get_nrows + + function i2_base_mlv_get_ncols(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function i2_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_i2_base_multivect_type + !! \brief Size in bytesa + !! + ! + function i2_base_mlv_sizeof(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_i2p) * x%get_nrows() * x%get_ncols() + + end function i2_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_i2_base_multivect_type + !! \brief Format + !! + ! + function i2_base_mlv_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'BASE' + end function i2_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_i2_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + function i2_base_mlv_get_vect(x) result(res) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function i2_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_i2_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + subroutine i2_base_mlv_set_scal(x,val) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine i2_base_mlv_set_scal + + ! + !> Function base_mlv_set_vect + !! \memberof psb_i2_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + subroutine i2_base_mlv_set_vect(x,val) + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine i2_base_mlv_set_vect + + + function i2_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function i2_base_mlv_use_buffer + + subroutine i2_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine i2_base_mlv_new_buffer + + + subroutine i2_base_mlv_maybe_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine i2_base_mlv_maybe_free_buffer + + subroutine i2_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_i2_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine i2_base_mlv_free_buffer + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_i2_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + subroutine i2_base_mlv_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine i2_base_mlv_gthab + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i2_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i2_base_mlv_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine i2_base_mlv_gthzv_x + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i2_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i2_base_mlv_gthzv(n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine i2_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i2_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i2_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:,:) + class(psb_i2_base_multivect_type) :: x + integer(psb_mpk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine i2_base_mlv_gthzm + + ! + ! New comm internals impl. + ! + subroutine i2_base_mlv_gthzbuf(i,ixb,n,idx,x) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, ixb + class(psb_i_base_vect_type) :: idx + class(psb_i2_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine i2_base_mlv_gthzbuf + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_i2_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + subroutine i2_base_mlv_sctb(n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine i2_base_mlv_sctb + + subroutine i2_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:,:) + class(psb_i2_base_multivect_type) :: y + integer(psb_mpk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine i2_base_mlv_sctbr2 + + subroutine i2_base_mlv_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer( psb_i2pk_) :: beta, x(:) + class(psb_i2_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine i2_base_mlv_sctb_x + + subroutine i2_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + use psi_serial_mod + implicit none + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i, iyb + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta + class(psb_i2_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine i2_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_i2_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine i2_base_mlv_device_wait() + implicit none + + end subroutine i2_base_mlv_device_wait + +end module psb_i2_base_multivect_mod diff --git a/base/modules/serial/psb_i2_vect_mod.F90 b/base/modules/serial/psb_i2_vect_mod.F90 new file mode 100644 index 000000000..136d9329f --- /dev/null +++ b/base/modules/serial/psb_i2_vect_mod.F90 @@ -0,0 +1,1273 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_i2_vect_mod +! +! This module contains the definition of the psb_i2_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +module psb_i2_vect_mod + + use psb_realloc_mod + use psb_i2_base_vect_mod + use psb_i_vect_mod + + type psb_i2_vect_type + class(psb_i2_base_vect_type), allocatable :: v + integer(psb_ipk_) :: nrmv = 0 + integer(psb_ipk_) :: remote_build=psb_matbld_noremote_ + integer(psb_ipk_) :: dupl = psb_dupl_add_ + integer(psb_i2pk_), allocatable :: rmtv(:) + integer(psb_lpk_), allocatable :: rmidx(:) + contains + procedure, pass(x) :: get_nrows => i2_vect_get_nrows + procedure, pass(x) :: sizeof => i2_vect_sizeof + procedure, pass(x) :: get_fmt => i2_vect_get_fmt + procedure, pass(x) :: is_remote_build => i2_vect_is_remote_build + procedure, pass(x) :: set_remote_build => i2_vect_set_remote_build + procedure, pass(x) :: get_nrmv => i2_vect_get_nrmv + procedure, pass(x) :: set_nrmv => i2_vect_set_nrmv + procedure, pass(x) :: all => i2_vect_all + procedure, pass(x) :: reall => i2_vect_reall + procedure, pass(x) :: zero => i2_vect_zero + procedure, pass(x) :: asb => i2_vect_asb + procedure, pass(x) :: set_dupl => i2_vect_set_dupl + procedure, pass(x) :: get_dupl => i2_vect_get_dupl + procedure, pass(x) :: set_ncfs => i2_vect_set_ncfs + procedure, pass(x) :: get_ncfs => i2_vect_get_ncfs + procedure, pass(x) :: set_state => i2_vect_set_state + procedure, pass(x) :: set_null => i2_vect_set_null + procedure, pass(x) :: set_bld => i2_vect_set_bld + procedure, pass(x) :: set_upd => i2_vect_set_upd + procedure, pass(x) :: set_asb => i2_vect_set_asb + procedure, pass(x) :: get_state => i2_vect_get_state + procedure, pass(x) :: is_null => i2_vect_is_null + procedure, pass(x) :: is_bld => i2_vect_is_bld + procedure, pass(x) :: is_upd => i2_vect_is_upd + procedure, pass(x) :: is_asb => i2_vect_is_asb + procedure, pass(x) :: reinit => i2_vect_reinit + + procedure, pass(x) :: gthab => i2_vect_gthab + procedure, pass(x) :: gthzv => i2_vect_gthzv + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => i2_vect_sctb + generic, public :: sct => sctb + procedure, pass(x) :: free => i2_vect_free + procedure, pass(x) :: ins_a => i2_vect_ins_a + procedure, pass(x) :: ins_v => i2_vect_ins_v + generic, public :: ins => ins_v, ins_a + procedure, pass(x) :: bld_x => i2_vect_bld_x + procedure, pass(x) :: bld_mn => i2_vect_bld_mn + procedure, pass(x) :: bld_en => i2_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en + procedure, pass(x) :: get_vect => i2_vect_get_vect + procedure, pass(x) :: cnv => i2_vect_cnv + procedure, pass(x) :: set_scal => i2_vect_set_scal + procedure, pass(x) :: set_vect => i2_vect_set_vect + generic, public :: set => set_vect, set_scal + procedure, pass(x) :: clone => i2_vect_clone + + procedure, pass(x) :: sync => i2_vect_sync + procedure, pass(x) :: is_host => i2_vect_is_host + procedure, pass(x) :: is_dev => i2_vect_is_dev + procedure, pass(x) :: is_sync => i2_vect_is_sync + procedure, pass(x) :: set_host => i2_vect_set_host + procedure, pass(x) :: set_dev => i2_vect_set_dev + procedure, pass(x) :: set_sync => i2_vect_set_sync + procedure, pass(x) :: check_addr => i2_vect_check_addr + + + + end type psb_i2_vect_type + + public :: psb_i2_vect + private :: constructor, size_const + interface psb_i2_vect + module procedure constructor, size_const + end interface psb_i2_vect + + private :: i2_vect_get_nrows, i2_vect_sizeof, i2_vect_get_fmt, & + & i2_vect_all, i2_vect_reall, i2_vect_zero, i2_vect_asb, & + & i2_vect_gthab, i2_vect_gthzv, i2_vect_sctb, & + & i2_vect_free, i2_vect_ins_a, i2_vect_ins_v, i2_vect_bld_x, & + & i2_vect_bld_mn, i2_vect_bld_en, i2_vect_get_vect, & + & i2_vect_cnv, i2_vect_set_scal, & + & i2_vect_set_vect, i2_vect_clone, i2_vect_sync, i2_vect_is_host, & + & i2_vect_is_dev, i2_vect_is_sync, i2_vect_set_host, & + & i2_vect_set_dev, i2_vect_set_sync, & + & i2_vect_set_remote_build, i2_is_remote_build, & + & i2_vect_set_dupl, i2_get_dupl, i2_vect_set_nrmv, i2_get_nrmv + + + class(psb_i2_base_vect_type), allocatable, target,& + & save, private :: psb_i2_base_vect_default + + interface psb_set_vect_default + module procedure psb_i2_set_vect_default + end interface psb_set_vect_default + + interface psb_get_vect_default + module procedure psb_i2_get_vect_default + end interface psb_get_vect_default + + +contains + + function i2_vect_get_dupl(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_dupl() + else + res = psb_dupl_null_ + end if + end function i2_vect_get_dupl + + subroutine i2_vect_set_dupl(x,val) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_dupl(val) + else + call x%v%set_dupl(psb_dupl_def_) + end if + end if + end subroutine i2_vect_set_dupl + + function i2_vect_get_ncfs(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_ncfs() + else + res = 0 + end if + end function i2_vect_get_ncfs + + subroutine i2_vect_set_ncfs(x,val) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (allocated(x%v)) then + if (present(val)) then + call x%v%set_ncfs(val) + else + call x%v%set_ncfs(0) + end if + end if + end subroutine i2_vect_set_ncfs + + function i2_vect_get_state(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + if (allocated(x%v)) then + res = x%v%get_state() + else + res = psb_vect_null_ + end if + end function i2_vect_get_state + + function i2_vect_is_null(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_null_) + end function i2_vect_is_null + + function i2_vect_is_bld(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_bld_) + end function i2_vect_is_bld + + function i2_vect_is_upd(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_upd_) + end function i2_vect_is_upd + + function i2_vect_is_asb(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + logical :: res + res = (x%get_state() == psb_vect_asb_) + end function i2_vect_is_asb + + subroutine i2_vect_set_state(n,x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + if (allocated(x%v)) then + call x%v%set_state(n) + end if + end subroutine i2_vect_set_state + + + subroutine i2_vect_set_null(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_null_) + end subroutine i2_vect_set_null + + subroutine i2_vect_set_bld(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_bld_) + end subroutine i2_vect_set_bld + + subroutine i2_vect_set_upd(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_upd_) + end subroutine i2_vect_set_upd + + subroutine i2_vect_set_asb(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + call x%set_state(psb_vect_asb_) + end subroutine i2_vect_set_asb + + function i2_vect_get_nrmv(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%nrmv + end function i2_vect_get_nrmv + + subroutine i2_vect_set_nrmv(x,val) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: val + + x%nrmv = val + end subroutine i2_vect_set_nrmv + + function i2_vect_is_remote_build(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function i2_vect_is_remote_build + + subroutine i2_vect_set_remote_build(x,val) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine i2_vect_set_remote_build + + subroutine psb_i2_set_vect_default(v) + implicit none + class(psb_i2_base_vect_type), intent(in) :: v + + if (allocated(psb_i2_base_vect_default)) then + deallocate(psb_i2_base_vect_default) + end if + allocate(psb_i2_base_vect_default, mold=v) + + end subroutine psb_i2_set_vect_default + + function psb_i2_get_vect_default(v) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: v + class(psb_i2_base_vect_type), pointer :: res + + res => psb_i2_get_base_vect_default() + + end function psb_i2_get_vect_default + + subroutine psb_i2_clear_vect_default() + implicit none + + if (allocated(psb_i2_base_vect_default)) then + deallocate(psb_i2_base_vect_default) + end if + + end subroutine psb_i2_clear_vect_default + + function psb_i2_get_base_vect_default() result(res) + implicit none + class(psb_i2_base_vect_type), pointer :: res + + if (.not.allocated(psb_i2_base_vect_default)) then + allocate(psb_i2_base_vect_type :: psb_i2_base_vect_default) + end if + + res => psb_i2_base_vect_default + + end function psb_i2_get_base_vect_default + + subroutine i2_vect_clone(x,y,info) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + ! + ! Using sourced allocation here creates + ! problems with handling of memory allocated + ! elsewhere (e.g. accelerators), hence delegation + ! to %bld method + ! + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine i2_vect_clone + + subroutine i2_vect_bld_x(x,invect,mold,scratch) + integer(psb_i2pk_), intent(in) :: invect(:) + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i2_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect,scratch=scratch_) + + end subroutine i2_vect_bld_x + + + subroutine i2_vect_bld_mn(x,n,mold,scratch) + integer(psb_mpk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + class(psb_i2_base_vect_type), pointer :: mld + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i2_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine i2_vect_bld_mn + + subroutine i2_vect_bld_en(x,n,mold,scratch) + integer(psb_epk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + logical :: scratch_ + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(scratch)) then + scratch_ = scratch + else + scratch_ = .false. + end if + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i2_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n,scratch=scratch_) + + end subroutine i2_vect_bld_en + + function i2_vect_get_vect(x,n) result(res) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function i2_vect_get_vect + + subroutine i2_vect_set_scal(x,val,first,last) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine i2_vect_set_scal + + subroutine i2_vect_set_vect(x,val,first,last) + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine i2_vect_set_vect + + subroutine i2_vect_check_addr(x) + class(psb_i2_vect_type), intent(inout) :: x + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%check_addr() + + end subroutine i2_vect_check_addr + + function constructor(x) result(this) + integer(psb_i2pk_) :: x(:) + type(psb_i2_vect_type) :: this + integer(psb_ipk_) :: info + + call this%bld(x) + call this%asb(size(x,kind=psb_ipk_),info) + + end function constructor + + + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_i2_vect_type) :: this + integer(psb_ipk_) :: info + + call this%bld(n) + call this%asb(n,info) + + end function size_const + + function i2_vect_get_nrows(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function i2_vect_get_nrows + + function i2_vect_sizeof(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function i2_vect_sizeof + + function i2_vect_get_fmt(x) result(res) + implicit none + class(psb_i2_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function i2_vect_get_fmt + + subroutine i2_vect_all(n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_i2_base_vect_type), intent(in), optional :: mold + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_i2_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + call x%set_bld() + end subroutine i2_vect_all + + subroutine i2_vect_reinit(x, info, clear) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: clear + + if (allocated(x%v)) call x%v%reinit(info,clear) + call x%set_upd() + + end subroutine i2_vect_reinit + + subroutine i2_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine i2_vect_reall + + subroutine i2_vect_zero(x) + use psi_serial_mod + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine i2_vect_zero + + subroutine i2_vect_asb(n, x, info, scratch) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + if (allocated(x%v)) then + call x%v%asb(n,info,scratch=scratch) + call x%set_asb() + end if + end subroutine i2_vect_asb + + subroutine i2_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine i2_vect_gthab + + subroutine i2_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine i2_vect_gthzv + + subroutine i2_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine i2_vect_sctb + + subroutine i2_vect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine i2_vect_free + + subroutine i2_vect_ins_a(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, dupl + + info = 0 + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + return + end if + dupl = x%get_dupl() + call x%v%ins(n,irl,val,dupl,maxr,info) + + end subroutine i2_vect_ins_a + + subroutine i2_vect_ins_v(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i2_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, maxr + class(psb_i_vect_type), intent(inout) :: irl + class(psb_i2_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, dupl + + info = 0 + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + info = psb_err_invalid_vect_state_ + return + end if + dupl = x%get_dupl() + call x%v%ins(n,irl%v,val%v,dupl,maxr,info) + + end subroutine i2_vect_ins_v + + + subroutine i2_vect_cnv(x,mold) + class(psb_i2_vect_type), intent(inout) :: x + class(psb_i2_base_vect_type), intent(in), optional :: mold + class(psb_i2_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_i2_get_base_vect_default()) + end if + if (allocated(x%v)) then + if (allocated(x%v%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%base_cpy(tmp) + call x%v%free(info) + endif + end if + call move_alloc(tmp,x%v) + + end subroutine i2_vect_cnv + + + subroutine i2_vect_sync(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine i2_vect_sync + + subroutine i2_vect_set_sync(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine i2_vect_set_sync + + subroutine i2_vect_set_host(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine i2_vect_set_host + + subroutine i2_vect_set_dev(x) + implicit none + class(psb_i2_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine i2_vect_set_dev + + function i2_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_i2_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function i2_vect_is_sync + + function i2_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_i2_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function i2_vect_is_host + + function i2_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_i2_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function i2_vect_is_dev + + + + +end module psb_i2_vect_mod + + +module psb_i2_multivect_mod + + use psb_i2_base_multivect_mod + use psb_const_mod + use psb_i_vect_mod + + + !private + + type psb_i2_multivect_type + class(psb_i2_base_multivect_type), allocatable :: v + integer(psb_ipk_) :: nrmv = 0 + integer(psb_ipk_) :: remote_build=psb_matbld_noremote_ + integer(psb_ipk_) :: dupl = psb_dupl_add_ + integer(psb_i2pk_), allocatable :: rmtv(:,:) + contains + procedure, pass(x) :: get_nrows => i2_mvect_get_nrows + procedure, pass(x) :: get_ncols => i2_mvect_get_ncols + procedure, pass(x) :: sizeof => i2_mvect_sizeof + procedure, pass(x) :: get_fmt => i2_mvect_get_fmt + procedure, pass(x) :: is_remote_build => i2_mvect_is_remote_build + procedure, pass(x) :: set_remote_build => i2_mvect_set_remote_build + procedure, pass(x) :: get_dupl => i2_mvect_get_dupl + procedure, pass(x) :: set_dupl => i2_mvect_set_dupl + + procedure, pass(x) :: all => i2_mvect_all + procedure, pass(x) :: reall => i2_mvect_reall + procedure, pass(x) :: zero => i2_mvect_zero + procedure, pass(x) :: asb => i2_mvect_asb + procedure, pass(x) :: sync => i2_mvect_sync + procedure, pass(x) :: free => i2_mvect_free + procedure, pass(x) :: ins => i2_mvect_ins + procedure, pass(x) :: bld_x => i2_mvect_bld_x + procedure, pass(x) :: bld_n => i2_mvect_bld_n + generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: get_vect => i2_mvect_get_vect + procedure, pass(x) :: cnv => i2_mvect_cnv + procedure, pass(x) :: set_scal => i2_mvect_set_scal + procedure, pass(x) :: set_vect => i2_mvect_set_vect + generic, public :: set => set_vect, set_scal + procedure, pass(x) :: clone => i2_mvect_clone + procedure, pass(x) :: gthab => i2_mvect_gthab + procedure, pass(x) :: gthzv => i2_mvect_gthzv + procedure, pass(x) :: gthzv_x => i2_mvect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => i2_mvect_sctb + procedure, pass(y) :: sctb_x => i2_mvect_sctb_x + generic, public :: sct => sctb, sctb_x + end type psb_i2_multivect_type + + public :: psb_i2_multivect, psb_i2_multivect_type,& + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_i2_base_multivect_type + + private + interface psb_i2_multivect + module procedure constructor, size_const + end interface psb_i2_multivect + + class(psb_i2_base_multivect_type), allocatable, target,& + & save, private :: psb_i2_base_multivect_default + + interface psb_set_multivect_default + module procedure psb_i2_set_multivect_default + end interface psb_set_multivect_default + + interface psb_get_multivect_default + module procedure psb_i2_get_multivect_default + end interface psb_get_multivect_default + + +contains + + + function i2_mvect_get_dupl(x) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = x%dupl + end function i2_mvect_get_dupl + + subroutine i2_mvect_set_dupl(x,val) + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%dupl = val + else + x%dupl = psb_dupl_def_ + end if + end subroutine i2_mvect_set_dupl + + + function i2_mvect_is_remote_build(x) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: x + logical :: res + res = (x%remote_build == psb_matbld_remote_) + end function i2_mvect_is_remote_build + + subroutine i2_mvect_set_remote_build(x,val) + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in), optional :: val + + if (present(val)) then + x%remote_build = val + else + x%remote_build = psb_matbld_remote_ + end if + end subroutine i2_mvect_set_remote_build + + + subroutine psb_i2_set_multivect_default(v) + implicit none + class(psb_i2_base_multivect_type), intent(in) :: v + + if (allocated(psb_i2_base_multivect_default)) then + deallocate(psb_i2_base_multivect_default) + end if + allocate(psb_i2_base_multivect_default, mold=v) + + end subroutine psb_i2_set_multivect_default + + function psb_i2_get_multivect_default(v) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: v + class(psb_i2_base_multivect_type), pointer :: res + + res => psb_i2_get_base_multivect_default() + + end function psb_i2_get_multivect_default + + + function psb_i2_get_base_multivect_default() result(res) + implicit none + class(psb_i2_base_multivect_type), pointer :: res + + if (.not.allocated(psb_i2_base_multivect_default)) then + allocate(psb_i2_base_multivect_type :: psb_i2_base_multivect_default) + end if + + res => psb_i2_base_multivect_default + + end function psb_i2_get_base_multivect_default + + + subroutine i2_mvect_clone(x,y,info) + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + class(psb_i2_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld_x(x%get_vect(),mold=x%v) + end if + end subroutine i2_mvect_clone + + subroutine i2_mvect_bld_x(x,invect,mold) + integer(psb_i2pk_), intent(in) :: invect(:,:) + class(psb_i2_multivect_type), intent(out) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_i2_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i2_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine i2_mvect_bld_x + + + subroutine i2_mvect_bld_n(x,m,n,mold,scratch) + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(out) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + logical, intent(in), optional :: scratch + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i2_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) + + end subroutine i2_mvect_bld_n + + function i2_mvect_get_vect(x) result(res) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_i2pk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function i2_mvect_get_vect + + subroutine i2_mvect_set_scal(x,val) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine i2_mvect_set_scal + + subroutine i2_mvect_set_vect(x,val) + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_i2pk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine i2_mvect_set_vect + + + function constructor(x) result(this) + integer(psb_i2pk_) :: x(:,:) + type(psb_i2_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld_x(x) + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + + end function constructor + + + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_i2_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld_n(m,n) + call this%asb(m,n,info) + + end function size_const + + function i2_mvect_get_nrows(x) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function i2_mvect_get_nrows + + function i2_mvect_get_ncols(x) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function i2_mvect_get_ncols + + function i2_mvect_sizeof(x) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function i2_mvect_sizeof + + function i2_mvect_get_fmt(x) result(res) + implicit none + class(psb_i2_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function i2_mvect_get_fmt + + subroutine i2_mvect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(out) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_i2_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine i2_mvect_all + + subroutine i2_mvect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine i2_mvect_reall + + subroutine i2_mvect_zero(x) + use psi_serial_mod + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine i2_mvect_zero + + subroutine i2_mvect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine i2_mvect_asb + + subroutine i2_mvect_sync(x) + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine i2_mvect_sync + + subroutine i2_mvect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: alpha, beta, y(:) + class(psb_i2_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine i2_mvect_gthab + + subroutine i2_mvect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: y(:) + class(psb_i2_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine i2_mvect_gthzv + + subroutine i2_mvect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: y(:) + class(psb_i2_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine i2_mvect_gthzv_x + + subroutine i2_mvect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: idx(:) + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine i2_mvect_sctb + + subroutine i2_mvect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_mpk_) :: n + integer(psb_ipk_) :: i + class(psb_i_base_vect_type) :: idx + integer(psb_i2pk_) :: beta, x(:) + class(psb_i2_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine i2_mvect_sctb_x + + subroutine i2_mvect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine i2_mvect_free + + subroutine i2_mvect_ins(n,irl,val,x,maxr,info) + use psi_serial_mod + implicit none + class(psb_i2_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n,maxr + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, dupl + + info = 0 + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + return + end if + dupl = x%get_dupl() + call x%v%ins(n,irl,val,dupl,maxr,info) + + end subroutine i2_mvect_ins + + + subroutine i2_mvect_cnv(x,mold) + class(psb_i2_multivect_type), intent(inout) :: x + class(psb_i2_base_multivect_type), intent(in), optional :: mold + class(psb_i2_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_i2_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine i2_mvect_cnv + + +end module psb_i2_multivect_mod + diff --git a/base/modules/serial/psb_i_base_vect_mod.F90 b/base/modules/serial/psb_i_base_vect_mod.F90 index 92fa7d9db..b95d4a6bc 100644 --- a/base/modules/serial/psb_i_base_vect_mod.F90 +++ b/base/modules/serial/psb_i_base_vect_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -33,7 +33,7 @@ ! package: psb_i_base_vect_mod ! ! This module contains the definition of the psb_i_base_vect type which -! is a container for dense vectors. +! is a container for dense vectors.\ ! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran @@ -47,7 +47,8 @@ module psb_i_base_vect_mod use psb_const_mod use psb_error_mod use psb_realloc_mod - use psb_neighbor_topology_mod + use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_ + use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free !> \namespace psb_base_mod \class psb_i_base_vect_type !! The psb_i_base_vect_type @@ -61,10 +62,9 @@ module psb_i_base_vect_mod !! type psb_i_base_vect_type !> Values. - integer(psb_ipk_), allocatable :: v(:) - integer(psb_ipk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) ! This is used only for Isend/Irecv scheme, to store the communication handles for each neighbor - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + integer(psb_ipk_), allocatable :: v(:) + integer(psb_ipk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle !> vector bldstate: !! null: pristine; @@ -74,13 +74,10 @@ module psb_i_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate = psb_vect_null_ - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs = 0 - integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology - + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -144,9 +141,7 @@ module psb_i_base_vect_mod procedure, nopass :: device_wait => i_base_device_wait procedure, pass(x) :: maybe_free_buffer => i_base_maybe_free_buffer procedure, pass(x) :: free_buffer => i_base_free_buffer - procedure, pass(x) :: new_comid => i_base_new_comid - procedure, pass(x) :: free_comid => i_base_free_comid - + ! ! Basic info procedure, pass(x) :: get_nrows => i_base_get_nrows @@ -176,9 +171,9 @@ module psb_i_base_vect_mod procedure, pass(x) :: check_addr => i_base_check_addr - ! Methods used to handle topology in neighbor_alltoallv communication scheme - procedure, pass(x) :: init_topology => i_base_init_topology - procedure, pass(x) :: free_topology => i_base_free_topology + + + end type psb_i_base_vect_type @@ -361,11 +356,12 @@ contains use psi_serial_mod use psb_realloc_mod implicit none - class(psb_i_base_vect_type), intent(out) :: x + class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: clear logical :: clear_ + info = 0 if (present(clear)) then clear_ = clear else @@ -755,13 +751,17 @@ contains use psb_realloc_mod implicit none class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%comm_handle)) then + call psb_comm_free(x%comm_handle, info_comm) + if (info_comm /= psb_success_) info = info_comm + end if if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') call x%set_null() @@ -807,24 +807,6 @@ contains & call x%free_buffer(info) end subroutine i_base_maybe_free_buffer - - ! - !> Function base_free_comid: - !! \memberof psb_i_base_vect_type - !! \brief Free aux MPI communication id buffer - !! - !! \param info return code - !! - ! - subroutine i_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine i_base_free_comid function i_base_get_ncfs(x) result(res) implicit none @@ -1297,17 +1279,6 @@ contains call psb_realloc(n,x%combuf,info) end subroutine i_base_new_buffer - subroutine i_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine i_base_new_comid - - ! ! shortcut alpha=1 beta=0 ! @@ -1393,33 +1364,6 @@ contains end subroutine i_base_sctb_buf - ! -------------------------------------------------------------------- - ! Implementation of methods used for neighbor alltoallv communication - ! -------------------------------------------------------------------- - subroutine i_base_init_topology(x, halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: halo_index(:) - integer(psb_ipk_), intent(in) :: num_exchanges, total_send_elems, total_recv_elems - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%init(halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - - end subroutine i_base_init_topology - - subroutine i_base_free_topology(x, info) - implicit none - class(psb_i_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%free(info) - - end subroutine i_base_free_topology - ! -------------------------------------------------------------------- end module psb_i_base_vect_mod @@ -1430,7 +1374,6 @@ module psb_i_base_multivect_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_i_base_vect_type !! The psb_i_base_vect_type @@ -1447,10 +1390,9 @@ module psb_i_base_multivect_mod type psb_i_base_multivect_type !> Values. - integer(psb_ipk_), allocatable :: v(:,:) - integer(psb_ipk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) ! This is used only for Isend/Irecv scheme, to store the communication handles for each neighbor - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + integer(psb_ipk_), allocatable :: v(:,:) + integer(psb_ipk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle !> vector bldstate: !! null: pristine; @@ -1464,9 +1406,6 @@ module psb_i_base_multivect_mod integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: ncfs = 0 integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology - contains ! ! Constructors/allocators @@ -1541,8 +1480,6 @@ module psb_i_base_multivect_mod procedure, nopass :: device_wait => i_base_mlv_device_wait procedure, pass(x) :: maybe_free_buffer => i_base_mlv_maybe_free_buffer procedure, pass(x) :: free_buffer => i_base_mlv_free_buffer - procedure, pass(x) :: new_comid => i_base_mlv_new_comid - procedure, pass(x) :: free_comid => i_base_mlv_free_comid ! ! Gather/scatter. These are needed for MPI interfacing. @@ -1559,11 +1496,6 @@ module psb_i_base_multivect_mod procedure, pass(y) :: sctb_x => i_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => i_base_mlv_sctb_buf generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf - - ! Neighbor alltoallv communication topology handling - procedure, pass(x) :: init_topology => i_base_mlv_init_topology - procedure, pass(x) :: free_topology => i_base_mlv_free_topology - end type psb_i_base_multivect_type interface psb_i_base_multivect @@ -1645,7 +1577,7 @@ contains logical, intent(in), optional :: scratch call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch) + call x%asb(m,n,info,scratch=scratch) end subroutine i_base_mlv_bld_n @@ -1697,6 +1629,7 @@ contains class(psb_i_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info + info = 0 if (allocated(x%v)) then call x%sync() x%v(:,:) = izero @@ -1925,23 +1858,26 @@ contains case(psb_dupl_err_) do i=1,ncfs if (any(vv(x%iv(i),:).ne.izero)) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') return else vv(x%iv(i),:) = x%v(i,:) end if end do case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() info =-7 end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < m) & + if ((x%get_nrows() < m).or.(x%get_ncols() \namespace psb_base_mod \class psb_l_base_vect_type !! The psb_l_base_vect_type @@ -62,10 +63,9 @@ module psb_l_base_vect_mod !! type psb_l_base_vect_type !> Values. - integer(psb_lpk_), allocatable :: v(:) - integer(psb_lpk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) ! This is used only for Isend/Irecv scheme, to store the communication handles for each neighbor - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + integer(psb_lpk_), allocatable :: v(:) + integer(psb_lpk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle !> vector bldstate: !! null: pristine; @@ -75,14 +75,10 @@ module psb_l_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate = psb_vect_null_ - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs = 0 - integer(psb_ipk_), allocatable :: iv(:) - - - type(psb_neighbor_topology_type) :: neighbor_topology - + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -146,9 +142,7 @@ module psb_l_base_vect_mod procedure, nopass :: device_wait => l_base_device_wait procedure, pass(x) :: maybe_free_buffer => l_base_maybe_free_buffer procedure, pass(x) :: free_buffer => l_base_free_buffer - procedure, pass(x) :: new_comid => l_base_new_comid - procedure, pass(x) :: free_comid => l_base_free_comid - + ! ! Basic info procedure, pass(x) :: get_nrows => l_base_get_nrows @@ -179,9 +173,9 @@ module psb_l_base_vect_mod procedure, pass(x) :: check_addr => l_base_check_addr - ! Methods used to handle topology in neighbor_alltoallv communication scheme - procedure, pass(x) :: init_topology => l_base_init_topology - procedure, pass(x) :: free_topology => l_base_free_topology + + + end type psb_l_base_vect_type @@ -363,11 +357,12 @@ contains use psi_serial_mod use psb_realloc_mod implicit none - class(psb_l_base_vect_type), intent(out) :: x + class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: clear logical :: clear_ + info = 0 if (present(clear)) then clear_ = clear else @@ -757,13 +752,17 @@ contains use psb_realloc_mod implicit none class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%comm_handle)) then + call psb_comm_free(x%comm_handle, info_comm) + if (info_comm /= psb_success_) info = info_comm + end if if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') call x%set_null() @@ -809,24 +808,6 @@ contains & call x%free_buffer(info) end subroutine l_base_maybe_free_buffer - - ! - !> Function base_free_comid: - !! \memberof psb_l_base_vect_type - !! \brief Free aux MPI communication id buffer - !! - !! \param info return code - !! - ! - subroutine l_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine l_base_free_comid function l_base_get_ncfs(x) result(res) implicit none @@ -1299,17 +1280,6 @@ contains call psb_realloc(n,x%combuf,info) end subroutine l_base_new_buffer - subroutine l_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine l_base_new_comid - - ! ! shortcut alpha=1 beta=0 ! @@ -1395,34 +1365,6 @@ contains end subroutine l_base_sctb_buf - ! -------------------------------------------------------------------- - ! Implementation of methods used for neighbor alltoallv communication - ! -------------------------------------------------------------------- - subroutine l_base_init_topology(x, halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: halo_index(:) - integer(psb_ipk_), intent(in) :: num_exchanges, total_send_elems, total_recv_elems - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%init(halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - - end subroutine l_base_init_topology - - subroutine l_base_free_topology(x, info) - implicit none - class(psb_l_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%free(info) - - end subroutine l_base_free_topology - ! -------------------------------------------------------------------- - end module psb_l_base_vect_mod @@ -1433,7 +1375,6 @@ module psb_l_base_multivect_mod use psb_error_mod use psb_realloc_mod use psb_l_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_l_base_vect_type !! The psb_l_base_vect_type @@ -1450,10 +1391,9 @@ module psb_l_base_multivect_mod type psb_l_base_multivect_type !> Values. - integer(psb_lpk_), allocatable :: v(:,:) - integer(psb_lpk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) ! This is used only for Isend/Irecv scheme, to store the communication handles for each neighbor - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + integer(psb_lpk_), allocatable :: v(:,:) + integer(psb_lpk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle !> vector bldstate: !! null: pristine; @@ -1467,9 +1407,6 @@ module psb_l_base_multivect_mod integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: ncfs = 0 integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology - contains ! ! Constructors/allocators @@ -1544,8 +1481,6 @@ module psb_l_base_multivect_mod procedure, nopass :: device_wait => l_base_mlv_device_wait procedure, pass(x) :: maybe_free_buffer => l_base_mlv_maybe_free_buffer procedure, pass(x) :: free_buffer => l_base_mlv_free_buffer - procedure, pass(x) :: new_comid => l_base_mlv_new_comid - procedure, pass(x) :: free_comid => l_base_mlv_free_comid ! ! Gather/scatter. These are needed for MPI interfacing. @@ -1562,12 +1497,6 @@ module psb_l_base_multivect_mod procedure, pass(y) :: sctb_x => l_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => l_base_mlv_sctb_buf generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf - - - ! Neighbor alltoallv communication topology handling - procedure, pass(x) :: init_topology => l_base_mlv_init_topology - procedure, pass(x) :: free_topology => l_base_mlv_free_topology - end type psb_l_base_multivect_type interface psb_l_base_multivect @@ -1649,7 +1578,7 @@ contains logical, intent(in), optional :: scratch call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch) + call x%asb(m,n,info,scratch=scratch) end subroutine l_base_mlv_bld_n @@ -1701,6 +1630,7 @@ contains class(psb_l_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info + info = 0 if (allocated(x%v)) then call x%sync() x%v(:,:) = lzero @@ -1929,23 +1859,26 @@ contains case(psb_dupl_err_) do i=1,ncfs if (any(vv(x%iv(i),:).ne.lzero)) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') return else vv(x%iv(i),:) = x%v(i,:) end if end do case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() info =-7 end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < m) & + if ((x%get_nrows() < m).or.(x%get_ncols() \namespace psb_base_mod \class psb_s_base_vect_type !! The psb_s_base_vect_type @@ -63,10 +64,10 @@ module psb_s_base_vect_mod !! type psb_s_base_vect_type !> Values. - real(psb_spk_), allocatable :: v(:) - real(psb_spk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + real(psb_spk_), allocatable :: v(:) + real(psb_spk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + !> vector bldstate: !! null: pristine; !! build: it's being filled with entries; @@ -75,12 +76,10 @@ module psb_s_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate = psb_vect_null_ - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs = 0 - integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -144,9 +143,7 @@ module psb_s_base_vect_mod procedure, nopass :: device_wait => s_base_device_wait procedure, pass(x) :: maybe_free_buffer => s_base_maybe_free_buffer procedure, pass(x) :: free_buffer => s_base_free_buffer - procedure, pass(x) :: new_comid => s_base_new_comid - procedure, pass(x) :: free_comid => s_base_free_comid - + ! ! Basic info procedure, pass(x) :: get_nrows => s_base_get_nrows @@ -161,6 +158,7 @@ module psb_s_base_vect_mod procedure, pass(x) :: set_vect => s_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> s_base_get_entry + procedure, pass(x) :: set_entry=> s_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -433,11 +431,12 @@ contains use psi_serial_mod use psb_realloc_mod implicit none - class(psb_s_base_vect_type), intent(out) :: x + class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: clear logical :: clear_ + info = 0 if (present(clear)) then clear_ = clear else @@ -827,13 +826,17 @@ contains use psb_realloc_mod implicit none class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%comm_handle)) then + call psb_comm_free(x%comm_handle, info_comm) + if (info_comm /= psb_success_) info = info_comm + end if if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') call x%set_null() @@ -879,24 +882,6 @@ contains & call x%free_buffer(info) end subroutine s_base_maybe_free_buffer - - ! - !> Function base_free_comid: - !! \memberof psb_s_base_vect_type - !! \brief Free aux MPI communication id buffer - !! - !! \param info return code - !! - ! - subroutine s_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine s_base_free_comid function s_base_get_ncfs(x) result(res) implicit none @@ -1285,15 +1270,33 @@ contains ! function s_base_get_entry(x, index) result(res) implicit none - class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function s_base_get_entry + subroutine s_base_set_entry(x, index, val) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine s_base_set_entry + ! ! Overwrite with absolute value ! @@ -2192,6 +2195,10 @@ contains res = min(res,abs(x%v(i))) end do #else + ! + ! From M&R&C: if the array is of size zero, MINVAL + ! returns the largest positive value + ! res = minval(x%v(1:n)) #endif end function s_base_min @@ -2372,17 +2379,6 @@ contains call psb_realloc(n,x%combuf,info) end subroutine s_base_new_buffer - subroutine s_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_s_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine s_base_new_comid - - ! ! shortcut alpha=1 beta=0 ! @@ -2622,7 +2618,6 @@ module psb_s_base_multivect_mod use psb_error_mod use psb_realloc_mod use psb_s_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_s_base_vect_type !! The psb_s_base_vect_type @@ -2639,10 +2634,10 @@ module psb_s_base_multivect_mod type psb_s_base_multivect_type !> Values. - real(psb_spk_), allocatable :: v(:,:) - real(psb_spk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + real(psb_spk_), allocatable :: v(:,:) + real(psb_spk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + !> vector bldstate: !! null: pristine; !! build: it's being filled with entries; @@ -2655,8 +2650,6 @@ module psb_s_base_multivect_mod integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: ncfs = 0 integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology contains ! ! Constructors/allocators @@ -2764,8 +2757,6 @@ module psb_s_base_multivect_mod procedure, nopass :: device_wait => s_base_mlv_device_wait procedure, pass(x) :: maybe_free_buffer => s_base_mlv_maybe_free_buffer procedure, pass(x) :: free_buffer => s_base_mlv_free_buffer - procedure, pass(x) :: new_comid => s_base_mlv_new_comid - procedure, pass(x) :: free_comid => s_base_mlv_free_comid ! ! Gather/scatter. These are needed for MPI interfacing. @@ -2863,7 +2854,7 @@ contains logical, intent(in), optional :: scratch call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch) + call x%asb(m,n,info,scratch=scratch) end subroutine s_base_mlv_bld_n @@ -2915,6 +2906,7 @@ contains class(psb_s_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info + info = 0 if (allocated(x%v)) then call x%sync() x%v(:,:) = szero @@ -3143,23 +3135,26 @@ contains case(psb_dupl_err_) do i=1,ncfs if (any(vv(x%iv(i),:).ne.szero)) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') return else vv(x%iv(i),:) = x%v(i,:) end if end do case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() info =-7 end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < m) & + if ((x%get_nrows() < m).or.(x%get_ncols() s_vect_check_addr procedure, pass(x) :: get_entry => s_vect_get_entry + procedure, pass(x) :: set_entry => s_vect_set_entry procedure, pass(x) :: dot_v => s_vect_dot_v procedure, pass(x) :: dot_a => s_vect_dot_a @@ -862,13 +863,21 @@ contains function s_vect_get_entry(x,index) result(res) implicit none - class(psb_s_vect_type), intent(in) :: x + class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res - res = 0 + res = szero if (allocated(x%v)) res = x%v%get_entry(index) end function s_vect_get_entry + subroutine s_vect_set_entry(x,index,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine s_vect_set_entry + function s_vect_dot_v(n,x,y) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x, y @@ -1430,7 +1439,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = szero + res = HUGE(sone) end if end function s_vect_min @@ -1739,19 +1748,20 @@ contains end subroutine s_mvect_bld_x - subroutine s_mvect_bld_n(x,m,n,mold) + subroutine s_mvect_bld_n(x,m,n,mold,scratch) integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(out) :: x class(psb_s_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_) :: info - + logical, intent(in), optional :: scratch + info = psb_success_ if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) endif - if (info == psb_success_) call x%v%bld(m,n) + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) end subroutine s_mvect_bld_n @@ -2232,3 +2242,4 @@ contains !!$ end function s_mvect_asum end module psb_s_multivect_mod + diff --git a/base/modules/serial/psb_z_base_mat_mod.F90 b/base/modules/serial/psb_z_base_mat_mod.F90 index 0d2c9e768..4aa6c3465 100644 --- a/base/modules/serial/psb_z_base_mat_mod.F90 +++ b/base/modules/serial/psb_z_base_mat_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index 7b08c25ee..c4dfe1511 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -33,7 +33,7 @@ ! package: psb_z_base_vect_mod ! ! This module contains the definition of the psb_z_base_vect type which -! is a container for dense vectors. +! is a container for dense vectors.\ ! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran @@ -47,9 +47,10 @@ module psb_z_base_vect_mod use psb_const_mod use psb_error_mod use psb_realloc_mod + use psb_comm_schemes_mod, only: psb_comm_handle_type, psb_comm_isend_irecv_, psb_comm_unknown_ + use psb_comm_factory_mod, only: psb_comm_set, psb_comm_free use psb_i_base_vect_mod use psb_l_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_z_base_vect_type !! The psb_z_base_vect_type @@ -63,10 +64,10 @@ module psb_z_base_vect_mod !! type psb_z_base_vect_type !> Values. - complex(psb_dpk_), allocatable :: v(:) - complex(psb_dpk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + complex(psb_dpk_), allocatable :: v(:) + complex(psb_dpk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + !> vector bldstate: !! null: pristine; !! build: it's being filled with entries; @@ -75,12 +76,10 @@ module psb_z_base_vect_mod !! in already existing entries. !! The transitions among the states are detailed in !! psb_T_vect_mod. - integer(psb_ipk_), private :: bldstate = psb_vect_null_ - integer(psb_ipk_), private :: dupl = psb_dupl_null_ - integer(psb_ipk_), private :: ncfs = 0 - integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology + integer(psb_ipk_), private :: bldstate = psb_vect_null_ + integer(psb_ipk_), private :: dupl = psb_dupl_null_ + integer(psb_ipk_), private :: ncfs = 0 + integer(psb_ipk_), allocatable :: iv(:) contains ! ! Constructors/allocators @@ -144,9 +143,7 @@ module psb_z_base_vect_mod procedure, nopass :: device_wait => z_base_device_wait procedure, pass(x) :: maybe_free_buffer => z_base_maybe_free_buffer procedure, pass(x) :: free_buffer => z_base_free_buffer - procedure, pass(x) :: new_comid => z_base_new_comid - procedure, pass(x) :: free_comid => z_base_free_comid - + ! ! Basic info procedure, pass(x) :: get_nrows => z_base_get_nrows @@ -161,6 +158,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: set_vect => z_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> z_base_get_entry + procedure, pass(x) :: set_entry=> z_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -245,10 +243,6 @@ module psb_z_base_vect_mod procedure, pass(z) :: addconst_v2 => z_base_addconst_v2 generic, public :: addconst => addconst_a2,addconst_v2 - ! Methods used to handle topology in neighbor_alltoallv communication scheme - procedure, pass(x) :: init_topology => z_base_init_topology - procedure, pass(x) :: free_topology => z_base_free_topology - end type psb_z_base_vect_type @@ -430,11 +424,12 @@ contains use psi_serial_mod use psb_realloc_mod implicit none - class(psb_z_base_vect_type), intent(out) :: x + class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: clear logical :: clear_ + info = 0 if (present(clear)) then clear_ = clear else @@ -824,13 +819,17 @@ contains use psb_realloc_mod implicit none class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: info_comm + integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if ((info == 0).and.allocated(x%combuf)) call x%free_buffer(info) - if ((info == 0).and.allocated(x%comid)) call x%free_comid(info) - if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%iv)) deallocate(x%iv, stat=info) + if ((info == 0).and.allocated(x%comm_handle)) then + call psb_comm_free(x%comm_handle, info_comm) + if (info_comm /= psb_success_) info = info_comm + end if if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') call x%set_null() @@ -876,24 +875,6 @@ contains & call x%free_buffer(info) end subroutine z_base_maybe_free_buffer - - ! - !> Function base_free_comid: - !! \memberof psb_z_base_vect_type - !! \brief Free aux MPI communication id buffer - !! - !! \param info return code - !! - ! - subroutine z_base_free_comid(x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - if (allocated(x%comid)) & - & deallocate(x%comid,stat=info) - end subroutine z_base_free_comid function z_base_get_ncfs(x) result(res) implicit none @@ -1282,15 +1263,33 @@ contains ! function z_base_get_entry(x, index) result(res) implicit none - class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function z_base_get_entry + subroutine z_base_set_entry(x, index, val) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine z_base_set_entry + ! ! Overwrite with absolute value ! @@ -2289,17 +2288,6 @@ contains call psb_realloc(n,x%combuf,info) end subroutine z_base_new_buffer - subroutine z_base_new_comid(n,x,info) - use psb_realloc_mod - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_), intent(out) :: info - - call psb_realloc(n,2_psb_ipk_,x%comid,info) - end subroutine z_base_new_comid - - ! ! shortcut alpha=1 beta=0 ! @@ -2438,35 +2426,6 @@ contains if (x%is_dev()) call x%sync() call z%addconst(x%v,b,info) end subroutine z_base_addconst_v2 - - - ! -------------------------------------------------------------------- - ! Implementation of methods used for neighbor alltoallv communication - ! -------------------------------------------------------------------- - subroutine z_base_init_topology(x, halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: halo_index(:) - integer(psb_ipk_), intent(in) :: num_exchanges, total_send_elems, total_recv_elems - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%init(halo_index, num_exchanges, & - & total_send_elems, total_recv_elems, ctxt, icomm, info) - - end subroutine z_base_init_topology - - subroutine z_base_free_topology(x, info) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - - call x%neighbor_topology%free(info) - - end subroutine z_base_free_topology - ! -------------------------------------------------------------------- end module psb_z_base_vect_mod @@ -2476,7 +2435,6 @@ module psb_z_base_multivect_mod use psb_error_mod use psb_realloc_mod use psb_z_base_vect_mod - use psb_neighbor_topology_mod !> \namespace psb_base_mod \class psb_z_base_vect_type !! The psb_z_base_vect_type @@ -2493,10 +2451,10 @@ module psb_z_base_multivect_mod type psb_z_base_multivect_type !> Values. - complex(psb_dpk_), allocatable :: v(:,:) - complex(psb_dpk_), allocatable :: combuf(:) - integer(psb_mpk_), allocatable :: comid(:,:) - integer(psb_mpk_) :: communication_handle ! This is used only for Isend/Irecv scheme, to store the communication handle for the whole halo exchange + complex(psb_dpk_), allocatable :: v(:,:) + complex(psb_dpk_), allocatable :: combuf(:) + class(psb_comm_handle_type), allocatable :: comm_handle + !> vector bldstate: !! null: pristine; !! build: it's being filled with entries; @@ -2509,8 +2467,6 @@ module psb_z_base_multivect_mod integer(psb_ipk_), private :: dupl = psb_dupl_null_ integer(psb_ipk_), private :: ncfs = 0 integer(psb_ipk_), allocatable :: iv(:) - - type(psb_neighbor_topology_type) :: neighbor_topology contains ! ! Constructors/allocators @@ -2618,8 +2574,6 @@ module psb_z_base_multivect_mod procedure, nopass :: device_wait => z_base_mlv_device_wait procedure, pass(x) :: maybe_free_buffer => z_base_mlv_maybe_free_buffer procedure, pass(x) :: free_buffer => z_base_mlv_free_buffer - procedure, pass(x) :: new_comid => z_base_mlv_new_comid - procedure, pass(x) :: free_comid => z_base_mlv_free_comid ! ! Gather/scatter. These are needed for MPI interfacing. @@ -2636,10 +2590,6 @@ module psb_z_base_multivect_mod procedure, pass(y) :: sctb_x => z_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => z_base_mlv_sctb_buf generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf - - ! Neighbor alltoallv communication topology handling - procedure, pass(x) :: init_topology => z_base_mlv_init_topology - procedure, pass(x) :: free_topology => z_base_mlv_free_topology end type psb_z_base_multivect_type interface psb_z_base_multivect @@ -2721,7 +2671,7 @@ contains logical, intent(in), optional :: scratch call psb_realloc(m,n,x%v,info) - call x%asb(m,n,info,scratch) + call x%asb(m,n,info,scratch=scratch) end subroutine z_base_mlv_bld_n @@ -2773,6 +2723,7 @@ contains class(psb_z_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info + info = 0 if (allocated(x%v)) then call x%sync() x%v(:,:) = zzero @@ -3001,23 +2952,26 @@ contains case(psb_dupl_err_) do i=1,ncfs if (any(vv(x%iv(i),:).ne.zzero)) then - call psb_errpush(psb_err_duplicate_coo,'vect-asb') + info = psb_err_duplicate_coo + call psb_errpush(info,'mvect-asb') return else vv(x%iv(i),:) = x%v(i,:) end if end do case default - write(psb_err_unit,*) 'Error in vect_asb: unsafe dupl',x%get_dupl() + write(psb_err_unit,*) 'Error in mvect_asb: unsafe dupl',x%get_dupl() info =-7 end select call psb_move_alloc(vv,x%v,info) if (allocated(x%iv)) deallocate(x%iv,stat=info) else if (x%is_upd().or.x%is_asb().or.scratch_) then - if (x%get_nrows() < m) & + if ((x%get_nrows() < m).or.(x%get_ncols() z_vect_check_addr procedure, pass(x) :: get_entry => z_vect_get_entry + procedure, pass(x) :: set_entry => z_vect_set_entry procedure, pass(x) :: dot_v => z_vect_dot_v procedure, pass(x) :: dot_a => z_vect_dot_a @@ -855,13 +856,21 @@ contains function z_vect_get_entry(x,index) result(res) implicit none - class(psb_z_vect_type), intent(in) :: x + class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res - res = 0 + res = zzero if (allocated(x%v)) res = x%v%get_entry(index) end function z_vect_get_entry + subroutine z_vect_set_entry(x,index,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine z_vect_set_entry + function z_vect_dot_v(n,x,y) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x, y @@ -1660,19 +1669,20 @@ contains end subroutine z_mvect_bld_x - subroutine z_mvect_bld_n(x,m,n,mold) + subroutine z_mvect_bld_n(x,m,n,mold,scratch) integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(out) :: x class(psb_z_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_) :: info - + logical, intent(in), optional :: scratch + info = psb_success_ if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) endif - if (info == psb_success_) call x%v%bld(m,n) + if (info == psb_success_) call x%v%bld(m,n,scratch=scratch) end subroutine z_mvect_bld_n @@ -2153,3 +2163,4 @@ contains !!$ end function z_mvect_asum end module psb_z_multivect_mod + diff --git a/base/modules/tools/psb_c_tools_a_mod.f90 b/base/modules/tools/psb_c_tools_a_mod.f90 index 8dd592b37..60e934748 100644 --- a/base/modules/tools/psb_c_tools_a_mod.f90 +++ b/base/modules/tools/psb_c_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 813ef370a..148ddf59f 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -444,6 +444,14 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: res end function + function psb_c_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_cspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: res + end function end interface interface psb_remap diff --git a/base/modules/tools/psb_d_tools_a_mod.f90 b/base/modules/tools/psb_d_tools_a_mod.f90 index 638953b4f..fd7b9ca57 100644 --- a/base/modules/tools/psb_d_tools_a_mod.f90 +++ b/base/modules/tools/psb_d_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 6ea554cd1..97f70fc13 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -444,6 +444,14 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res end function + function psb_d_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_dspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: res + end function end interface interface psb_remap diff --git a/base/modules/tools/psb_e_tools_a_mod.f90 b/base/modules/tools/psb_e_tools_a_mod.f90 index f8a27cb54..b54a593c8 100644 --- a/base/modules/tools/psb_e_tools_a_mod.f90 +++ b/base/modules/tools/psb_e_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_i2_tools_a_mod.f90 b/base/modules/tools/psb_i2_tools_a_mod.f90 index b8d52bb42..7471adcc9 100644 --- a/base/modules/tools/psb_i2_tools_a_mod.f90 +++ b/base/modules/tools/psb_i2_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index 767dc8e56..28899c9fe 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index 92fe875bd..078f06dc7 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_m_tools_a_mod.f90 b/base/modules/tools/psb_m_tools_a_mod.f90 index a1de6caa5..65211e353 100644 --- a/base/modules/tools/psb_m_tools_a_mod.f90 +++ b/base/modules/tools/psb_m_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_s_tools_a_mod.f90 b/base/modules/tools/psb_s_tools_a_mod.f90 index 85a2b0296..1881202b1 100644 --- a/base/modules/tools/psb_s_tools_a_mod.f90 +++ b/base/modules/tools/psb_s_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index d4fa78924..c87607bc9 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -444,6 +444,14 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res end function + function psb_s_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_sspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: res + end function end interface interface psb_remap diff --git a/base/modules/tools/psb_z_tools_a_mod.f90 b/base/modules/tools/psb_z_tools_a_mod.f90 index 4c421f266..1052e57db 100644 --- a/base/modules/tools/psb_z_tools_a_mod.f90 +++ b/base/modules/tools/psb_z_tools_a_mod.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 2c105b2bb..8a6c2d34c 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -444,6 +444,14 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: res end function + function psb_z_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_zspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: res + end function end interface interface psb_remap diff --git a/base/psblas/psb_cabs_vect.f90 b/base/psblas/psb_cabs_vect.f90 index cb1921953..29780abe5 100644 --- a/base/psblas/psb_cabs_vect.f90 +++ b/base/psblas/psb_cabs_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index e30ba8fe2..90ef18ead 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -148,7 +148,7 @@ end function psb_camax !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -371,7 +371,7 @@ end function psb_camax_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -496,7 +496,7 @@ end subroutine psb_camaxvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 index 7b9b32759..7b336ebd9 100644 --- a/base/psblas/psb_casum.f90 +++ b/base/psblas/psb_casum.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -261,7 +261,7 @@ end function psb_casum_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -391,7 +391,7 @@ end function psb_casumv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index da9458490..bb93f7eb8 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -146,7 +146,7 @@ end subroutine psb_caxpby_vect ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -418,7 +418,7 @@ end subroutine psb_caxpby !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -538,7 +538,7 @@ end subroutine psb_caxpbyv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_ccmp_vect.f90 b/base/psblas/psb_ccmp_vect.f90 index 5de955138..a77631556 100644 --- a/base/psblas/psb_ccmp_vect.f90 +++ b/base/psblas/psb_ccmp_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cdiv_vect.f90 b/base/psblas/psb_cdiv_vect.f90 index 0fe4594a1..9a2525a13 100644 --- a/base/psblas/psb_cdiv_vect.f90 +++ b/base/psblas/psb_cdiv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 index ed300b7ce..7be3f6663 100644 --- a/base/psblas/psb_cdot.f90 +++ b/base/psblas/psb_cdot.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -301,7 +301,7 @@ end function psb_cdot !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -437,7 +437,7 @@ end function psb_cdotv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -572,7 +572,7 @@ end subroutine psb_cdotvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cgetmatinfo.F90 b/base/psblas/psb_cgetmatinfo.F90 index 66db76936..eade65178 100644 --- a/base/psblas/psb_cgetmatinfo.F90 +++ b/base/psblas/psb_cgetmatinfo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cinv_vect.f90 b/base/psblas/psb_cinv_vect.f90 index 25589f32b..d5a4ac1f7 100644 --- a/base/psblas/psb_cinv_vect.f90 +++ b/base/psblas/psb_cinv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cmlt_vect.f90 b/base/psblas/psb_cmlt_vect.f90 index 9b4037bf0..c88514992 100644 --- a/base/psblas/psb_cmlt_vect.f90 +++ b/base/psblas/psb_cmlt_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index 0de8ed162..de99ca703 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -155,7 +155,7 @@ end function psb_cnrm2 !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -610,7 +610,7 @@ end function psb_cnrm2_weightmask_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index f28719ea5..38cdc45fb 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 index 540ddde3e..f3e96c2f2 100644 --- a/base/psblas/psb_cspmm.f90 +++ b/base/psblas/psb_cspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -85,8 +85,8 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1 integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1 - name = 'psb_cspmv_vect' - info = psb_success_ + name='psb_cspmv' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -155,14 +155,12 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info if (trans_ == 'N') then ! Matrix is not transposed @@ -174,12 +172,14 @@ subroutine psb_cspmv_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_) call psi_swapdata(psb_swap_send_,czero,x%v,desc_a,info,data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_send_,& + & czero,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) if (do_timings) call psb_tic(mv_phase3) - if (doswap_) call psi_swapdata(psb_swap_recv_,czero,x%v,desc_a,info,data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_recv_,& + & czero,x%v,desc_a,info,data=psb_comm_halo_) if (do_timings) call psb_toc(mv_phase3) if (do_timings) call psb_tic(mv_phase4) call a%and%spmm(alpha,x%v,cone,y%v,info) @@ -194,7 +194,8 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (do_timings) call psb_tic(mv_phase11) if (doswap_) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),czero,x%v,desc_a,info,data=psb_comm_halo_) + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & czero,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) @@ -237,8 +238,10 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& end if if (doswap_) then - call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),cone,y%v,desc_a,info) - if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),cone,y%v,desc_a,info,data=psb_comm_ovr_) + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & cone,y%v,desc_a,info) + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & cone,y%v,desc_a,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info @@ -295,7 +298,7 @@ end subroutine psb_cspmv_vect ! work(:) - complex,(optional). Working area. ! doswap - logical(optional). Whether to performe halo updates. ! -subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& & trans, k, jx, jy, work, doswap) use psb_base_mod, psb_protect_name => psb_cspmm use psi_mod @@ -326,8 +329,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw, doswap_ integer(psb_ipk_) :: debug_level, debug_unit - name = 'psb_cspmm' - info = psb_success_ + name='psb_cspmm' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -606,7 +609,7 @@ end subroutine psb_cspmm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -644,7 +647,7 @@ end subroutine psb_cspmm ! work(:) - complex,(optional). Working area. ! doswap - logical(optional). Whether to performe halo updates. ! -subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& & trans, work, doswap) use psb_base_mod, psb_protect_name => psb_cspmv use psi_mod diff --git a/base/psblas/psb_cspnrm1.f90 b/base/psblas/psb_cspnrm1.f90 index 92b04ebb4..a912bfd1a 100644 --- a/base/psblas/psb_cspnrm1.f90 +++ b/base/psblas/psb_cspnrm1.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_cspsm.f90 b/base/psblas/psb_cspsm.f90 index cd5dd8416..1f2e8e430 100644 --- a/base/psblas/psb_cspsm.f90 +++ b/base/psblas/psb_cspsm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,35 +71,36 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& use psi_mod implicit none - complex(psb_spk_), intent(in) :: alpha, beta - type(psb_c_vect_type), intent(inout) :: x - type(psb_c_vect_type), intent(inout) :: y - type(psb_cspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_c_vect_type), intent(inout) :: x + type(psb_c_vect_type), intent(inout) :: y + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info type(psb_c_vect_type), intent(inout), optional :: diag - character, intent(in), optional :: trans, scale + character, intent(in), optional :: trans, scale integer(psb_ipk_), intent(in), optional :: choice ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, & + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, iiy, jjy, idx, ndm + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm - character :: lscale - integer(psb_ipk_), parameter :: nb=4 - complex(psb_spk_),pointer :: xp(:), yp(:) - character :: itrans - character(len=20) :: name, ch_err - logical :: aliw + character :: lscale + integer(psb_ipk_), parameter :: nb=4 + complex(psb_spk_),pointer :: xp(:), yp(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw name = 'psb_cspsv_vect' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -157,8 +158,8 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),cone,y%v,desc_a,info,data=psb_comm_ovr_) - + call psi_swapdata(psb_comm_status_sync_,cone,y%v,desc_a,info,data=psb_comm_ovr_) if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') diff --git a/base/psblas/psb_dabs_vect.f90 b/base/psblas/psb_dabs_vect.f90 index 0b655d9cd..29e0ec6ea 100644 --- a/base/psblas/psb_dabs_vect.f90 +++ b/base/psblas/psb_dabs_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index 490d4ffe3..db45d5687 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -148,7 +148,7 @@ end function psb_damax !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -371,7 +371,7 @@ end function psb_damax_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -496,7 +496,7 @@ end subroutine psb_damaxvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -689,11 +689,11 @@ function psb_dmin_vect(x, desc_a, info,global) result(res) goto 9999 end if - ! compute local max + ! compute local min if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%minreal(desc_a%get_local_rows()) else - res = dzero + res = HUGE(done) end if ! compute global min diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index ff4399de3..dbb8e5ee1 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -261,7 +261,7 @@ end function psb_dasum_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -391,7 +391,7 @@ end function psb_dasumv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index f86b7fe9f..20b7f71b9 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -146,7 +146,7 @@ end subroutine psb_daxpby_vect ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -418,7 +418,7 @@ end subroutine psb_daxpby !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -538,7 +538,7 @@ end subroutine psb_daxpbyv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dcmp_vect.f90 b/base/psblas/psb_dcmp_vect.f90 index b52b34d12..c9549be6c 100644 --- a/base/psblas/psb_dcmp_vect.f90 +++ b/base/psblas/psb_dcmp_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -121,7 +121,7 @@ end subroutine psb_dcmp_vect ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_ddiv_vect.f90 b/base/psblas/psb_ddiv_vect.f90 index 7f958e19b..37fe59e1b 100644 --- a/base/psblas/psb_ddiv_vect.f90 +++ b/base/psblas/psb_ddiv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index 633c75498..611e43067 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -301,7 +301,7 @@ end function psb_ddot !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -437,7 +437,7 @@ end function psb_ddotv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -572,7 +572,7 @@ end subroutine psb_ddotvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dgetmatinfo.F90 b/base/psblas/psb_dgetmatinfo.F90 index 9b3270118..0b743a86d 100644 --- a/base/psblas/psb_dgetmatinfo.F90 +++ b/base/psblas/psb_dgetmatinfo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dinv_vect.f90 b/base/psblas/psb_dinv_vect.f90 index 2159398f0..5c238c4b8 100644 --- a/base/psblas/psb_dinv_vect.f90 +++ b/base/psblas/psb_dinv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dmlt_vect.f90 b/base/psblas/psb_dmlt_vect.f90 index 80a138c16..b8ff807b4 100644 --- a/base/psblas/psb_dmlt_vect.f90 +++ b/base/psblas/psb_dmlt_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 7ebe94391..cce877f32 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -155,7 +155,7 @@ end function psb_dnrm2 !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -610,7 +610,7 @@ end function psb_dnrm2_weightmask_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index e06bc71bb..a251ae825 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index 4a18227df..84dc5f2c7 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -57,8 +57,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& & trans, doswap) use psb_base_mod, psb_protect_name => psb_dspmv_vect use psi_mod - use psb_comm_factory_mod - implicit none real(psb_dpk_), intent(in) :: alpha, beta @@ -87,8 +85,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1 integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1 - name = 'psb_dspmv_vect' - info = psb_success_ + name='psb_dspmv' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -96,7 +94,7 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ctxt = desc_a%get_context() + ctxt=desc_a%get_context() call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -157,14 +155,12 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info if (trans_ == 'N') then ! Matrix is not transposed @@ -185,7 +181,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (do_timings) call psb_tic(mv_phase2) call a%ad%spmm(alpha,x%v,beta,y%v,info) if (do_timings) call psb_tic(mv_phase3) - if (doswap_) call psi_swapdata(psb_comm_status_wait_, dzero, x%v, desc_a, info, data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_recv_,& + & dzero,x%v,desc_a,info,data=psb_comm_halo_) if (do_timings) call psb_toc(mv_phase3) if (do_timings) call psb_tic(mv_phase4) call a%and%spmm(alpha,x%v,done,y%v,info) @@ -241,10 +238,10 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& end if if (doswap_) then - call psi_swaptran(psb_comm_status_sync_, done, y%v, desc_a, info) - if (info == psb_success_) then - call psi_swapdata(psb_comm_status_sync_, done, y%v, desc_a, info, data=psb_comm_ovr_) - end if + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & done,y%v,desc_a,info) + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & done,y%v,desc_a,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info @@ -301,12 +298,10 @@ end subroutine psb_dspmv_vect ! work(:) - real,(optional). Working area. ! doswap - logical(optional). Whether to performe halo updates. ! -subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& & trans, k, jx, jy, work, doswap) use psb_base_mod, psb_protect_name => psb_dspmm use psi_mod - use psb_comm_factory_mod - implicit none real(psb_dpk_), intent(in) :: alpha, beta @@ -334,8 +329,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw, doswap_ integer(psb_ipk_) :: debug_level, debug_unit - name = 'psb_dspmm' - info = psb_success_ + name='psb_dspmm' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -470,9 +465,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if (doswap_.and.(np>1)) then ib1=min(nb,lik) xp => x(iix:lldx,jjx:jjx+ib1-1) - if (doswap_) & - & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & ib1,dzero,xp,desc_a,iwork,info) + if (doswap_)& + & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & ib1,dzero,xp,desc_a,iwork,info) blk: do i=1, lik, nb @@ -558,17 +553,14 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) - - if (doswap_)then ik = lik ! This should not be an issue, we are expecting the values ! to be small, within PSB_IPK - call psi_swaptran(psb_comm_status_sync_,& - & ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) - if (info == psb_success_) call psi_swapdata(psb_comm_status_sync_,& + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & ik,done,y(:,1:ik),desc_a,iwork,info) + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & @@ -617,7 +609,7 @@ end subroutine psb_dspmm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -655,11 +647,10 @@ end subroutine psb_dspmm ! work(:) - real,(optional). Working area. ! doswap - logical(optional). Whether to performe halo updates. ! -subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& & trans, work, doswap) use psb_base_mod, psb_protect_name => psb_dspmv use psi_mod - use psb_comm_factory_mod implicit none real(psb_dpk_), intent(in) :: alpha, beta @@ -686,8 +677,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw, doswap_ integer(psb_ipk_) :: debug_level, debug_unit - name = 'psb_dspmv' - info = psb_success_ + name='psb_dspmv' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -806,7 +797,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& end if if (doswap_) then - call psi_swapdata(psb_comm_status_sync_,dzero,x,desc_a,iwork,info,data=psb_comm_halo_) + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & dzero,x,desc_a,iwork,info,data=psb_comm_halo_) end if call psb_csmm(alpha,a,x,beta,y,info) @@ -872,10 +864,11 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& end if if (doswap_) then - call psi_swaptran(psb_comm_status_sync_,done,yp,desc_a,iwork,info) - if (info == psb_success_) then - call psi_swapdata(psb_comm_status_sync_,done,yp,desc_a,iwork,info,data=psb_comm_ovr_) - end if + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & done,yp,desc_a,iwork,info) + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) + if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info if(info /= psb_success_) then diff --git a/base/psblas/psb_dspnrm1.f90 b/base/psblas/psb_dspnrm1.f90 index 6bdb4eea3..c415bc526 100644 --- a/base/psblas/psb_dspnrm1.f90 +++ b/base/psblas/psb_dspnrm1.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index 317a3d7b8..be8db5d74 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,35 +71,36 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& use psi_mod implicit none - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_d_vect_type), intent(inout) :: x - type(psb_d_vect_type), intent(inout) :: y - type(psb_dspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_d_vect_type), intent(inout) :: x + type(psb_d_vect_type), intent(inout) :: y + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info type(psb_d_vect_type), intent(inout), optional :: diag - character, intent(in), optional :: trans, scale + character, intent(in), optional :: trans, scale integer(psb_ipk_), intent(in), optional :: choice ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, & + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, iiy, jjy, idx, ndm + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm - character :: lscale - integer(psb_ipk_), parameter :: nb=4 - real(psb_dpk_),pointer :: xp(:), yp(:) - character :: itrans - character(len=20) :: name, ch_err - logical :: aliw + character :: lscale + integer(psb_ipk_), parameter :: nb=4 + real(psb_dpk_),pointer :: xp(:), yp(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw name = 'psb_dspsv_vect' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -157,8 +158,8 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),done,y%v,desc_a,info,data=psb_comm_ovr_) - - + call psi_swapdata(psb_comm_status_sync_,done,y%v,desc_a,info,data=psb_comm_ovr_) if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') @@ -238,7 +237,7 @@ end subroutine psb_dspsv_vect ! jy - integer(optional). The column offset for ( Y ). Default: 1 ! work(:) - real, optional Working area. ! -subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, k, jx, jy, work) use psb_base_mod, psb_protect_name => psb_dspsm use psi_mod @@ -484,7 +483,7 @@ end subroutine psb_dspsm ! d(:) - real, optional Matrix for diagonal scaling. ! work(:) - real, optional Working area. ! -subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_dspsv use psi_mod diff --git a/base/psblas/psb_sabs_vect.f90 b/base/psblas/psb_sabs_vect.f90 index 2eb22d73c..aad75a030 100644 --- a/base/psblas/psb_sabs_vect.f90 +++ b/base/psblas/psb_sabs_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index b2858d965..ca923b94b 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -148,7 +148,7 @@ end function psb_samax !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -371,7 +371,7 @@ end function psb_samax_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -496,7 +496,7 @@ end subroutine psb_samaxvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -689,11 +689,11 @@ function psb_smin_vect(x, desc_a, info,global) result(res) goto 9999 end if - ! compute local max + ! compute local min if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%minreal(desc_a%get_local_rows()) else - res = szero + res = HUGE(sone) end if ! compute global min diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 index 6ca62d244..b4e503d0b 100644 --- a/base/psblas/psb_sasum.f90 +++ b/base/psblas/psb_sasum.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -261,7 +261,7 @@ end function psb_sasum_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -391,7 +391,7 @@ end function psb_sasumv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index 61f71b5a7..f47c866b6 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -146,7 +146,7 @@ end subroutine psb_saxpby_vect ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -418,7 +418,7 @@ end subroutine psb_saxpby !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -538,7 +538,7 @@ end subroutine psb_saxpbyv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_scmp_vect.f90 b/base/psblas/psb_scmp_vect.f90 index 7a7ff0028..d4678486b 100644 --- a/base/psblas/psb_scmp_vect.f90 +++ b/base/psblas/psb_scmp_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -121,7 +121,7 @@ end subroutine psb_scmp_vect ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sdiv_vect.f90 b/base/psblas/psb_sdiv_vect.f90 index 70bb96d03..223ce77ff 100644 --- a/base/psblas/psb_sdiv_vect.f90 +++ b/base/psblas/psb_sdiv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 index cf0678a71..00671c7d5 100644 --- a/base/psblas/psb_sdot.f90 +++ b/base/psblas/psb_sdot.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -301,7 +301,7 @@ end function psb_sdot !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -437,7 +437,7 @@ end function psb_sdotv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -572,7 +572,7 @@ end subroutine psb_sdotvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sgetmatinfo.F90 b/base/psblas/psb_sgetmatinfo.F90 index 5d5ae9c42..25c626ab1 100644 --- a/base/psblas/psb_sgetmatinfo.F90 +++ b/base/psblas/psb_sgetmatinfo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sinv_vect.f90 b/base/psblas/psb_sinv_vect.f90 index f658b1779..757899097 100644 --- a/base/psblas/psb_sinv_vect.f90 +++ b/base/psblas/psb_sinv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_smlt_vect.f90 b/base/psblas/psb_smlt_vect.f90 index 04b3150cb..b9dcff878 100644 --- a/base/psblas/psb_smlt_vect.f90 +++ b/base/psblas/psb_smlt_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index bb9b3effb..fcc36eaa9 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -155,7 +155,7 @@ end function psb_snrm2 !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -610,7 +610,7 @@ end function psb_snrm2_weightmask_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index d48bb5f9a..0f9ba9dae 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 index e660c3e61..acb656ca3 100644 --- a/base/psblas/psb_sspmm.f90 +++ b/base/psblas/psb_sspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -72,7 +72,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & - & liwork, iiy, jjy, ib, ip, idx + & iiy, jjy, ib, ip, idx integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja integer(psb_ipk_), parameter :: nb=4 real(psb_spk_), pointer :: xp(:), yp(:) @@ -85,8 +85,8 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1 integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1 - name = 'psb_sspmv_vect' - info = psb_success_ + name='psb_sspmv' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -94,7 +94,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ctxt = desc_a%get_context() + ctxt=desc_a%get_context() call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -155,14 +155,12 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info if (trans_ == 'N') then ! Matrix is not transposed @@ -174,12 +172,14 @@ subroutine psb_sspmv_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_) call psi_swapdata(psb_swap_send_,szero,x%v,desc_a,info,data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_send_,& + & szero,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) if (do_timings) call psb_tic(mv_phase3) - if (doswap_) call psi_swapdata(psb_swap_recv_,szero,x%v,desc_a,info,data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_recv_,& + & szero,x%v,desc_a,info,data=psb_comm_halo_) if (do_timings) call psb_toc(mv_phase3) if (do_timings) call psb_tic(mv_phase4) call a%and%spmm(alpha,x%v,sone,y%v,info) @@ -194,7 +194,8 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (do_timings) call psb_tic(mv_phase11) if (doswap_) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),szero,x%v,desc_a,info,data=psb_comm_halo_) + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & szero,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) @@ -237,8 +238,10 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& end if if (doswap_) then - call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),sone,y%v,desc_a,info) - if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),sone,y%v,desc_a,info,data=psb_comm_ovr_) + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & sone,y%v,desc_a,info) + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & sone,y%v,desc_a,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info @@ -606,7 +609,7 @@ end subroutine psb_sspmm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sspnrm1.f90 b/base/psblas/psb_sspnrm1.f90 index 09ea96fbd..3f1bf39cd 100644 --- a/base/psblas/psb_sspnrm1.f90 +++ b/base/psblas/psb_sspnrm1.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_sspsm.f90 b/base/psblas/psb_sspsm.f90 index 0299cdfa8..ab2eb9bd9 100644 --- a/base/psblas/psb_sspsm.f90 +++ b/base/psblas/psb_sspsm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,35 +71,36 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& use psi_mod implicit none - real(psb_spk_), intent(in) :: alpha, beta - type(psb_s_vect_type), intent(inout) :: x - type(psb_s_vect_type), intent(inout) :: y - type(psb_sspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: alpha, beta + type(psb_s_vect_type), intent(inout) :: x + type(psb_s_vect_type), intent(inout) :: y + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info type(psb_s_vect_type), intent(inout), optional :: diag - character, intent(in), optional :: trans, scale + character, intent(in), optional :: trans, scale integer(psb_ipk_), intent(in), optional :: choice ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, & + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, iiy, jjy, idx, ndm + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm - character :: lscale - integer(psb_ipk_), parameter :: nb=4 - real(psb_spk_),pointer :: xp(:), yp(:) - character :: itrans - character(len=20) :: name, ch_err - logical :: aliw + character :: lscale + integer(psb_ipk_), parameter :: nb=4 + real(psb_spk_),pointer :: xp(:), yp(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw name = 'psb_sspsv_vect' info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 + info = psb_err_internal_error_ + goto 9999 end if ctxt = desc_a%get_context() @@ -178,9 +179,7 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if (choice_ > 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),sone,y%v,desc_a,info,data=psb_comm_ovr_) - - + call psi_swapdata(psb_comm_status_sync_,sone,y%v,desc_a,info,data=psb_comm_ovr_) if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') @@ -484,7 +483,7 @@ end subroutine psb_sspsm ! d(:) - real, optional Matrix for diagonal scaling. ! work(:) - real, optional Working area. ! -subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_sspsv use psi_mod diff --git a/base/psblas/psb_zabs_vect.f90 b/base/psblas/psb_zabs_vect.f90 index 8c027727f..17d064f8a 100644 --- a/base/psblas/psb_zabs_vect.f90 +++ b/base/psblas/psb_zabs_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index 79cc6d96d..ff3331e4c 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -148,7 +148,7 @@ end function psb_zamax !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -371,7 +371,7 @@ end function psb_zamax_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -496,7 +496,7 @@ end subroutine psb_zamaxvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 63061d0b7..4e07c9970 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -261,7 +261,7 @@ end function psb_zasum_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -391,7 +391,7 @@ end function psb_zasumv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index e47a871d1..df5d7f773 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -146,7 +146,7 @@ end subroutine psb_zaxpby_vect ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -418,7 +418,7 @@ end subroutine psb_zaxpby !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -538,7 +538,7 @@ end subroutine psb_zaxpbyv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zcmp_vect.f90 b/base/psblas/psb_zcmp_vect.f90 index 01e1cecf8..4729b4465 100644 --- a/base/psblas/psb_zcmp_vect.f90 +++ b/base/psblas/psb_zcmp_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zdiv_vect.f90 b/base/psblas/psb_zdiv_vect.f90 index 22d8b21ce..ad4d069d8 100644 --- a/base/psblas/psb_zdiv_vect.f90 +++ b/base/psblas/psb_zdiv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index 97ecbedf3..0b03c30a6 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -301,7 +301,7 @@ end function psb_zdot !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -437,7 +437,7 @@ end function psb_zdotv !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -572,7 +572,7 @@ end subroutine psb_zdotvs !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zgetmatinfo.F90 b/base/psblas/psb_zgetmatinfo.F90 index 7cc3bfaea..cdf74d0e3 100644 --- a/base/psblas/psb_zgetmatinfo.F90 +++ b/base/psblas/psb_zgetmatinfo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zinv_vect.f90 b/base/psblas/psb_zinv_vect.f90 index 593d342b9..b631f2365 100644 --- a/base/psblas/psb_zinv_vect.f90 +++ b/base/psblas/psb_zinv_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zmlt_vect.f90 b/base/psblas/psb_zmlt_vect.f90 index 5db9cdb47..2dc83fd84 100644 --- a/base/psblas/psb_zmlt_vect.f90 +++ b/base/psblas/psb_zmlt_vect.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 5612a01db..76f51ffc1 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -155,7 +155,7 @@ end function psb_znrm2 !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -610,7 +610,7 @@ end function psb_znrm2_weightmask_vect !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index 9afae6e7f..f1ba036bd 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index 8055a7d01..2d687c7b1 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -72,7 +72,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me,& & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & - & liwork, iiy, jjy, ib, ip, idx + & iiy, jjy, ib, ip, idx integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja integer(psb_ipk_), parameter :: nb=4 complex(psb_dpk_), pointer :: xp(:), yp(:) @@ -85,8 +85,8 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1 integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1 - name = 'psb_zspmv_vect' - info = psb_success_ + name='psb_zspmv' + info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 @@ -94,7 +94,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - ctxt = desc_a%get_context() + ctxt=desc_a%get_context() call psb_info(ctxt, me, np) if (np == -1) then info = psb_err_context_error_ @@ -155,14 +155,12 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy= psb_debug_comp_) & - & write(debug_unit,*) me,' ',trim(name),' Allocated work ', info if (trans_ == 'N') then ! Matrix is not transposed @@ -174,12 +172,14 @@ subroutine psb_zspmv_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_) call psi_swapdata(psb_swap_send_,zzero,x%v,desc_a,info,data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_send_,& + & zzero,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) if (do_timings) call psb_tic(mv_phase3) - if (doswap_) call psi_swapdata(psb_swap_recv_,zzero,x%v,desc_a,info,data=psb_comm_halo_) + if (doswap_) call psi_swapdata(psb_swap_recv_,& + & zzero,x%v,desc_a,info,data=psb_comm_halo_) if (do_timings) call psb_toc(mv_phase3) if (do_timings) call psb_tic(mv_phase4) call a%and%spmm(alpha,x%v,zone,y%v,info) @@ -194,7 +194,8 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (do_timings) call psb_tic(mv_phase11) if (doswap_) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),zzero,x%v,desc_a,info,data=psb_comm_halo_) + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & zzero,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) @@ -231,14 +232,16 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (info == psb_success_) call psi_ovrl_restore(x%v,xvsave,desc_a,info) if (info /= psb_success_) then info = psb_err_from_subroutine_ - ch_err = 'psb_csmm' + ch_err='psb_csmm' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if if (doswap_) then - call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),zone,y%v,desc_a,info) - if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),zone,y%v,desc_a,info,data=psb_comm_ovr_) + call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& + & zone,y%v,desc_a,info) + if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & zone,y%v,desc_a,info,data=psb_comm_ovr_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' swaptran ', info @@ -606,7 +609,7 @@ end subroutine psb_zspmm !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zspnrm1.f90 b/base/psblas/psb_zspnrm1.f90 index cb568ab87..a6dc8e88f 100644 --- a/base/psblas/psb_zspnrm1.f90 +++ b/base/psblas/psb_zspnrm1.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index d48ca3a45..6f0a2797d 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,29 +71,29 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& use psi_mod implicit none - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_z_vect_type), intent(inout) :: x - type(psb_z_vect_type), intent(inout) :: y - type(psb_zspmat_type), intent(inout) :: a - type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_z_vect_type), intent(inout) :: x + type(psb_z_vect_type), intent(inout) :: y + type(psb_zspmat_type), intent(inout) :: a + type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info type(psb_z_vect_type), intent(inout), optional :: diag - character, intent(in), optional :: trans, scale + character, intent(in), optional :: trans, scale integer(psb_ipk_), intent(in), optional :: choice ! locals type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, & + integer(psb_ipk_) :: np, me, & & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, iiy, jjy, idx, ndm + & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm - character :: lscale - integer(psb_ipk_), parameter :: nb=4 - complex(psb_dpk_),pointer :: xp(:), yp(:) - character :: itrans - character(len=20) :: name, ch_err - logical :: aliw + character :: lscale + integer(psb_ipk_), parameter :: nb=4 + complex(psb_dpk_),pointer :: xp(:), yp(:) + character :: itrans + character(len=20) :: name, ch_err + logical :: aliw name = 'psb_zspsv_vect' info = psb_success_ @@ -158,8 +158,8 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& if ((info == 0).and.(lldy 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),zone,y%v,desc_a,info,data=psb_comm_ovr_) - - + call psi_swapdata(psb_comm_status_sync_,zone,y%v,desc_a,info,data=psb_comm_ovr_) if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') @@ -239,7 +237,7 @@ end subroutine psb_zspsv_vect ! jy - integer(optional). The column offset for ( Y ). Default: 1 ! work(:) - complex, optional Working area. ! -subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, k, jx, jy, work) use psb_base_mod, psb_protect_name => psb_zspsm use psi_mod @@ -485,7 +483,7 @@ end subroutine psb_zspsm ! d(:) - complex, optional Matrix for diagonal scaling. ! work(:) - complex, optional Working area. ! -subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& +subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& & trans, scale, choice, diag, work) use psb_base_mod, psb_protect_name => psb_zspsv use psi_mod diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 25cd290a3..e04a742c4 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 53ffcea91..3b9ff2758 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_c_csc_impl.F90 b/base/serial/impl/psb_c_csc_impl.F90 index 4073a1ac7..7553ec01b 100644 --- a/base/serial/impl/psb_c_csc_impl.F90 +++ b/base/serial/impl/psb_c_csc_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_c_csr_impl.F90 b/base/serial/impl/psb_c_csr_impl.F90 index af5812da9..d0fe429d8 100644 --- a/base/serial/impl/psb_c_csr_impl.F90 +++ b/base/serial/impl/psb_c_csr_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 81479084f..e796d5431 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_c_rb_idx_tree_impl.F90 b/base/serial/impl/psb_c_rb_idx_tree_impl.F90 index 04730aaa2..0a99b6de7 100644 --- a/base/serial/impl/psb_c_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_c_rb_idx_tree_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index 5f849bea1..0b54601ac 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index 7a79847eb..99d4e2f63 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_d_csc_impl.F90 b/base/serial/impl/psb_d_csc_impl.F90 index e91285cd0..d11cd14da 100644 --- a/base/serial/impl/psb_d_csc_impl.F90 +++ b/base/serial/impl/psb_d_csc_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_d_csr_impl.F90 b/base/serial/impl/psb_d_csr_impl.F90 index 5ff34a2f6..763bd4f22 100644 --- a/base/serial/impl/psb_d_csr_impl.F90 +++ b/base/serial/impl/psb_d_csr_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index c744f7f5b..9b6fe8795 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 index 241338fb3..62af7430c 100644 --- a/base/serial/impl/psb_d_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_d_rb_idx_tree_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index c070e7167..7fe841e3f 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index b4e6a8df9..d03103f81 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_s_csc_impl.F90 b/base/serial/impl/psb_s_csc_impl.F90 index 9dd32d589..dec7ccfb2 100644 --- a/base/serial/impl/psb_s_csc_impl.F90 +++ b/base/serial/impl/psb_s_csc_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_s_csr_impl.F90 b/base/serial/impl/psb_s_csr_impl.F90 index a7dd2c159..92bdc0f02 100644 --- a/base/serial/impl/psb_s_csr_impl.F90 +++ b/base/serial/impl/psb_s_csr_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index a27a24a5d..dda59ee8e 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_s_rb_idx_tree_impl.F90 b/base/serial/impl/psb_s_rb_idx_tree_impl.F90 index 5241225ea..88e4fc82c 100644 --- a/base/serial/impl/psb_s_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_s_rb_idx_tree_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 2d68d1527..b488fd0da 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index 949d0384c..d7439be9d 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_z_csc_impl.F90 b/base/serial/impl/psb_z_csc_impl.F90 index 4a06d8d83..c987996ee 100644 --- a/base/serial/impl/psb_z_csc_impl.F90 +++ b/base/serial/impl/psb_z_csc_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_z_csr_impl.F90 b/base/serial/impl/psb_z_csr_impl.F90 index 9f6c9b941..17dbd4abc 100644 --- a/base/serial/impl/psb_z_csr_impl.F90 +++ b/base/serial/impl/psb_z_csr_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index e1f9310b1..ee1895177 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/impl/psb_z_rb_idx_tree_impl.F90 b/base/serial/impl/psb_z_rb_idx_tree_impl.F90 index 42695158e..26b4d88e5 100644 --- a/base/serial/impl/psb_z_rb_idx_tree_impl.F90 +++ b/base/serial/impl/psb_z_rb_idx_tree_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_camax_s.f90 b/base/serial/psb_camax_s.f90 index d9073d0f9..99f51840d 100644 --- a/base/serial/psb_camax_s.f90 +++ b/base/serial/psb_camax_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_casum_s.f90 b/base/serial/psb_casum_s.f90 index 1c357cc89..32977f2f3 100644 --- a/base/serial/psb_casum_s.f90 +++ b/base/serial/psb_casum_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_cgeprt.f90 b/base/serial/psb_cgeprt.f90 index e05d673b6..1ec98f32f 100644 --- a/base/serial/psb_cgeprt.f90 +++ b/base/serial/psb_cgeprt.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_cnumbmm.f90 b/base/serial/psb_cnumbmm.f90 index 920187b3d..9559ad44d 100644 --- a/base/serial/psb_cnumbmm.f90 +++ b/base/serial/psb_cnumbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_crwextd.f90 b/base/serial/psb_crwextd.f90 index 9676ad247..243f91535 100644 --- a/base/serial/psb_crwextd.f90 +++ b/base/serial/psb_crwextd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_cspspmm.F90 b/base/serial/psb_cspspmm.F90 index 64fedbfea..e7ab8ec20 100644 --- a/base/serial/psb_cspspmm.F90 +++ b/base/serial/psb_cspspmm.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_csymbmm.f90 b/base/serial/psb_csymbmm.f90 index 0f8c18ab8..519b1689c 100644 --- a/base/serial/psb_csymbmm.f90 +++ b/base/serial/psb_csymbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_damax_s.f90 b/base/serial/psb_damax_s.f90 index 66aef2882..372dd3082 100644 --- a/base/serial/psb_damax_s.f90 +++ b/base/serial/psb_damax_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_dasum_s.f90 b/base/serial/psb_dasum_s.f90 index 1ab42614f..88b7925ea 100644 --- a/base/serial/psb_dasum_s.f90 +++ b/base/serial/psb_dasum_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_dgeprt.f90 b/base/serial/psb_dgeprt.f90 index ae4c5b11c..6d1a540d6 100644 --- a/base/serial/psb_dgeprt.f90 +++ b/base/serial/psb_dgeprt.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index 4719b2bc7..6763774e6 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_drwextd.f90 b/base/serial/psb_drwextd.f90 index 70c73f831..5b7dab4db 100644 --- a/base/serial/psb_drwextd.f90 +++ b/base/serial/psb_drwextd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_dspspmm.F90 b/base/serial/psb_dspspmm.F90 index 4b37df0e7..e2b394ad9 100644 --- a/base/serial/psb_dspspmm.F90 +++ b/base/serial/psb_dspspmm.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index d647d2707..b892ecbab 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_samax_s.f90 b/base/serial/psb_samax_s.f90 index f2b1fee2c..df39aa244 100644 --- a/base/serial/psb_samax_s.f90 +++ b/base/serial/psb_samax_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_sasum_s.f90 b/base/serial/psb_sasum_s.f90 index c692cbd48..e7307d772 100644 --- a/base/serial/psb_sasum_s.f90 +++ b/base/serial/psb_sasum_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_sgeprt.f90 b/base/serial/psb_sgeprt.f90 index 9f3205fdf..b3afeb855 100644 --- a/base/serial/psb_sgeprt.f90 +++ b/base/serial/psb_sgeprt.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_snumbmm.f90 b/base/serial/psb_snumbmm.f90 index 99075a8b5..8cc1c38dd 100644 --- a/base/serial/psb_snumbmm.f90 +++ b/base/serial/psb_snumbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_srwextd.f90 b/base/serial/psb_srwextd.f90 index 3ecd7a8e9..4cceb8f57 100644 --- a/base/serial/psb_srwextd.f90 +++ b/base/serial/psb_srwextd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_sspspmm.F90 b/base/serial/psb_sspspmm.F90 index bc3352ee7..5ab8b62a9 100644 --- a/base/serial/psb_sspspmm.F90 +++ b/base/serial/psb_sspspmm.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_ssymbmm.f90 b/base/serial/psb_ssymbmm.f90 index d76b48ea3..97108ee11 100644 --- a/base/serial/psb_ssymbmm.f90 +++ b/base/serial/psb_ssymbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_zamax_s.f90 b/base/serial/psb_zamax_s.f90 index 4a4085664..2adca0c5b 100644 --- a/base/serial/psb_zamax_s.f90 +++ b/base/serial/psb_zamax_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_zasum_s.f90 b/base/serial/psb_zasum_s.f90 index 35a043ed9..13fdc6f1b 100644 --- a/base/serial/psb_zasum_s.f90 +++ b/base/serial/psb_zasum_s.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_zgeprt.f90 b/base/serial/psb_zgeprt.f90 index 3fc0eb0c2..3788600d1 100644 --- a/base/serial/psb_zgeprt.f90 +++ b/base/serial/psb_zgeprt.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_znumbmm.f90 b/base/serial/psb_znumbmm.f90 index 31b8f6b28..30fee807a 100644 --- a/base/serial/psb_znumbmm.f90 +++ b/base/serial/psb_znumbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_zrwextd.f90 b/base/serial/psb_zrwextd.f90 index 393a3d9d4..c8cd0e43d 100644 --- a/base/serial/psb_zrwextd.f90 +++ b/base/serial/psb_zrwextd.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_zspspmm.F90 b/base/serial/psb_zspspmm.F90 index a37bd013f..b7faf46aa 100644 --- a/base/serial/psb_zspspmm.F90 +++ b/base/serial/psb_zspspmm.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index 9c31b0e73..a9703d446 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_c_serial_impl.F90 b/base/serial/psi_c_serial_impl.F90 index d6706c887..441211e54 100644 --- a/base/serial/psi_c_serial_impl.F90 +++ b/base/serial/psi_c_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_cgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_cgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_d_serial_impl.F90 b/base/serial/psi_d_serial_impl.F90 index 772f28ea8..aafd9d983 100644 --- a/base/serial/psi_d_serial_impl.F90 +++ b/base/serial/psi_d_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_dgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_dgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_e_serial_impl.F90 b/base/serial/psi_e_serial_impl.F90 index 10ea49cf7..5ede8afbf 100644 --- a/base/serial/psi_e_serial_impl.F90 +++ b/base/serial/psi_e_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_egelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_egelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_i2_serial_impl.F90 b/base/serial/psi_i2_serial_impl.F90 index ae6ee65a6..8eccd73c9 100644 --- a/base/serial/psi_i2_serial_impl.F90 +++ b/base/serial/psi_i2_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_i2gelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_i2gelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_m_serial_impl.F90 b/base/serial/psi_m_serial_impl.F90 index 25eaca324..0b6a69831 100644 --- a/base/serial/psi_m_serial_impl.F90 +++ b/base/serial/psi_m_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_mgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_mgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_s_serial_impl.F90 b/base/serial/psi_s_serial_impl.F90 index 6baa8dd75..580975c10 100644 --- a/base/serial/psi_s_serial_impl.F90 +++ b/base/serial/psi_s_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_sgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_sgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/psi_z_serial_impl.F90 b/base/serial/psi_z_serial_impl.F90 index dcd02540b..7292320e8 100644 --- a/base/serial/psi_z_serial_impl.F90 +++ b/base/serial/psi_z_serial_impl.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -230,7 +230,7 @@ end subroutine psb_m_zgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -431,7 +431,7 @@ end subroutine psb_e_zgelp !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_c_hsort_impl.f90 b/base/serial/sort/psb_c_hsort_impl.f90 index 4251ddaad..674ff8d47 100644 --- a/base/serial/sort/psb_c_hsort_impl.f90 +++ b/base/serial/sort/psb_c_hsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_c_isort_impl.f90 b/base/serial/sort/psb_c_isort_impl.f90 index 0251d37e2..cf3857ad6 100644 --- a/base/serial/sort/psb_c_isort_impl.f90 +++ b/base/serial/sort/psb_c_isort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_c_msort_impl.f90 b/base/serial/sort/psb_c_msort_impl.f90 index e61ee9e1e..e94fcd7ab 100644 --- a/base/serial/sort/psb_c_msort_impl.f90 +++ b/base/serial/sort/psb_c_msort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this - ! software without specific written permission. + ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_c_qsort_impl.f90 b/base/serial/sort/psb_c_qsort_impl.f90 index 0111e9c23..300b3fec4 100644 --- a/base/serial/sort/psb_c_qsort_impl.f90 +++ b/base/serial/sort/psb_c_qsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_d_hsort_impl.f90 b/base/serial/sort/psb_d_hsort_impl.f90 index dac327d16..7f5a48bda 100644 --- a/base/serial/sort/psb_d_hsort_impl.f90 +++ b/base/serial/sort/psb_d_hsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_d_isort_impl.f90 b/base/serial/sort/psb_d_isort_impl.f90 index 62b6eed14..da6338709 100644 --- a/base/serial/sort/psb_d_isort_impl.f90 +++ b/base/serial/sort/psb_d_isort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_d_msort_impl.f90 b/base/serial/sort/psb_d_msort_impl.f90 index 7c38f27dc..43ef089ff 100644 --- a/base/serial/sort/psb_d_msort_impl.f90 +++ b/base/serial/sort/psb_d_msort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this - ! software without specific written permission. + ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_d_qsort_impl.f90 b/base/serial/sort/psb_d_qsort_impl.f90 index c397ba233..6cd35eb01 100644 --- a/base/serial/sort/psb_d_qsort_impl.f90 +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_e_hsort_impl.f90 b/base/serial/sort/psb_e_hsort_impl.f90 index 8fa00a834..7d9d6104b 100644 --- a/base/serial/sort/psb_e_hsort_impl.f90 +++ b/base/serial/sort/psb_e_hsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_e_isort_impl.f90 b/base/serial/sort/psb_e_isort_impl.f90 index 20d3600ca..68c1d35d6 100644 --- a/base/serial/sort/psb_e_isort_impl.f90 +++ b/base/serial/sort/psb_e_isort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_e_msort_impl.f90 b/base/serial/sort/psb_e_msort_impl.f90 index 93ac8a6eb..beeabf5a0 100644 --- a/base/serial/sort/psb_e_msort_impl.f90 +++ b/base/serial/sort/psb_e_msort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this - ! software without specific written permission. + ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_e_qsort_impl.f90 b/base/serial/sort/psb_e_qsort_impl.f90 index ea3bfd140..9057ff36f 100644 --- a/base/serial/sort/psb_e_qsort_impl.f90 +++ b/base/serial/sort/psb_e_qsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_i2_hsort_impl.f90 b/base/serial/sort/psb_i2_hsort_impl.f90 new file mode 100644 index 000000000..06fff6bae --- /dev/null +++ b/base/serial/sort/psb_i2_hsort_impl.f90 @@ -0,0 +1,721 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The merge-sort and quicksort routines are implemented in the +! serial/aux directory +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_i2hsort(x,ix,dir,flag,reord) + use psb_sort_mod, psb_protect_name => psb_i2hsort + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag,reord + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: flag_, err_act, info, reord_ + integer(psb_ipk_) :: n, i, l, dir_ + integer(psb_i2pk_) :: key + integer(psb_ipk_) :: index + integer(psb_i2pk_), allocatable :: tx(:) + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + + if (present(reord)) then + reord_ = reord + else + reord_= psb_sort_reord_x_ + end if + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_) + ! OK + case (psb_asort_up_,psb_asort_down_) + ! OK + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_ + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_ == psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + select case(reord_) + case (psb_sort_reord_x_) + + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + case(psb_sort_noreord_x_) + tx = x + + l = 0 + do i=1, n + key = tx(i) + index = ix(i) + call psi_idx_insert_heap(key,index,l,tx,ix,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_idx_heap_get_first(key,index,l,tx,ix,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + tx(i) = key + ix(i) = index + end do + end select + else if (.not.present(ix)) then + select case(reord_) + case (psb_sort_reord_x_) + !OK + case default + ierr(1) = 5; ierr(2) = reord_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + l = 0 + do i=1, n + key = x(i) + call psi_insert_heap(key,l,x,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_i2_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_i2hsort + + + +! +! These are packaged so that they can be used to implement +! a heapsort. +! +! +! Programming note: +! In the implementation of the heap_get_first function +! we have code like this +! +! if ( ( heap(2*i) < heap(2*i+1) ) .or.& +! & (2*i == last)) then +! j = 2*i +! else +! j = 2*i + 1 +! end if +! +! It looks like the 2*i+1 could overflow the array, but this +! is not true because there is a guard statement +! if (i>last/2) exit +! and because last has just been reduced by 1 when defining the return value, +! therefore 2*i+1 may be greater than the current value of last, +! but cannot be greater than the value of last when the routine was entered +! hence it is safe. +! +! +! + +subroutine psi_i2_insert_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_i2_insert_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_i2pk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: dir + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2 + integer(psb_i2pk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_i2_insert_heap + + +subroutine psi_i2_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_i2_heap_get_first + implicit none + + integer(psb_i2pk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, j + integer(psb_i2pk_) :: temp + + + info = psb_success_ + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_i2_heap_get_first + + +subroutine psi_i2_idx_insert_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_i2_idx_insert_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + integer(psb_i2pk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: index,dir + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:),last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2, itemp + integer(psb_i2pk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_i2_idx_insert_heap + +subroutine psi_i2_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_i2_idx_heap_get_first + implicit none + + integer(psb_i2pk_), intent(inout) :: key + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(inout) :: last,idxs(:) + integer(psb_ipk_), intent(in) :: dir + + integer(psb_ipk_) :: i, j,itemp + integer(psb_i2pk_) :: temp + + info = psb_success_ + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_i2_idx_heap_get_first + + + + diff --git a/base/serial/sort/psb_i2_isort_impl.f90 b/base/serial/sort/psb_i2_isort_impl.f90 new file mode 100644 index 000000000..f582d2689 --- /dev/null +++ b/base/serial/sort/psb_i2_isort_impl.f90 @@ -0,0 +1,378 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The insertion sort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_i2isort(x,ix,dir,flag,reord) + use psb_sort_mod, psb_protect_name => psb_i2isort + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag,reord + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act, reord_ + integer(psb_ipk_) :: n, i + integer(psb_i2pk_), allocatable :: tx(:) + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_i2isort' + call psb_erractionsave(err_act) + + if (present(reord)) then + reord_ = reord + else + reord_= psb_sort_reord_x_ + end if + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + select case(reord_) + case (psb_sort_reord_x_) + select case(dir_) + case (psb_sort_up_) + call psi_i2isrx_up(n,x,ix) + case (psb_sort_down_) + call psi_i2isrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_i2aisrx_up(n,x,ix) + case (psb_asort_down_) + call psi_i2aisrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + case(psb_sort_noreord_x_) + tx = x + select case(dir_) + case (psb_sort_up_) + call psi_i2isrx_up(n,tx,ix) + case (psb_sort_down_) + call psi_i2isrx_dw(n,tx,ix) + case (psb_asort_up_) + call psi_i2aisrx_up(n,tx,ix) + case (psb_asort_down_) + call psi_i2aisrx_dw(n,tx,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + case default + ierr(1) = 5; ierr(2) = reord_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(reord_) + case (psb_sort_reord_x_) + !OK + case default + ierr(1) = 5; ierr(2) = reord_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + select case(dir_) + case (psb_sort_up_) + call psi_i2isr_up(n,x) + case (psb_sort_down_) + call psi_i2isr_dw(n,x) + case (psb_asort_up_) + call psi_i2aisr_up(n,x) + case (psb_asort_down_) + call psi_i2aisr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_i2isort + +subroutine psi_i2isrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2isrx_up + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_i2isrx_up + +subroutine psi_i2isrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2isrx_dw + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_i2isrx_dw + + +subroutine psi_i2isr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_i2isr_up + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_i2isr_up + +subroutine psi_i2isr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_i2isr_dw + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_i2isr_dw + +subroutine psi_i2aisrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2aisrx_up + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_i2aisrx_up + +subroutine psi_i2aisrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2aisrx_dw + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_i2aisrx_dw + +subroutine psi_i2aisr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_i2aisr_up + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_i2aisr_up + +subroutine psi_i2aisr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_i2aisr_dw + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_i2pk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_i2aisr_dw + diff --git a/base/serial/sort/psb_i2_msort_impl.f90 b/base/serial/sort/psb_i2_msort_impl.f90 new file mode 100644 index 000000000..67835351d --- /dev/null +++ b/base/serial/sort/psb_i2_msort_impl.f90 @@ -0,0 +1,667 @@ + ! + ! Parallel Sparse BLAS version 3.5 + ! (C) Copyright 2006-2018 + ! Salvatore Filippone + ! Alfredo Buttari + ! + ! Redistribution and use in source and binary forms, with or without + ! modification, are permitted provided that the following conditions + ! are met: + ! 1. Redistributions of source code must retain the above copyright + ! notice, this list of conditions and the following disclaimer. + ! 2. Redistributions in binary form must reproduce the above copyright + ! notice, this list of conditions, and the following disclaimer in the + ! documentation and/or other materials provided with the distribution. + ! 3. The name of the PSBLAS group or the names of its contributors may + ! not be used to endorse or promote products derived from this + ! software without specific prior written permission. + ! + ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + ! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS + ! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + ! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + ! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + ! POSSIBILITY OF SUCH DAMAGE. + ! + ! + ! + ! The merge-sort routines + ! References: + ! D. Knuth + ! The Art of Computer Programming, vol. 3 + ! Addison-Wesley + ! + ! Aho, Hopcroft, Ullman + ! Data Structures and Algorithms + ! Addison-Wesley + ! +logical function psb_i2isaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_i2isaperm + implicit none + + integer(psb_i2pk_), intent(in) :: n + integer(psb_i2pk_), intent(in) :: eip(n) + integer(psb_i2pk_), allocatable :: ip(:) + integer(psb_i2pk_) :: i,j,m, info + + + psb_i2isaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= psb_success_) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n + psb_i2isaperm = .false. + return + endif + enddo + + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = abs(ip(m)) + if (j /= m) then + psb_i2isaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue + + return +end function psb_i2isaperm + + +subroutine psb_i2msort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_i2msort_u + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_msort_u' + call psb_erractionsave(err_act) + + n = size(x) + + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_i2msort_u + +subroutine psb_i2msort(x,ix,dir,flag,reord) + use psb_sort_mod, psb_protect_name => psb_i2msort + use psb_error_mod + use psb_ip_reord_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag, reord + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act, reord_ + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_i2msort' + call psb_erractionsave(err_act) + + if (present(reord)) then + reord_ = reord + else + reord_= psb_sort_reord_x_ + end if + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_i2_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_i2_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_i2_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_i2_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_i2_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + select case(reord_) + case(psb_sort_reord_x_) + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + case(psb_sort_noreord_x_) + if (present(ix)) then + call psb_ip_reord(n,ix,iaux) + else + call psb_errpush(psb_err_no_optional_arg_,name,a_err="ix") + goto 9999 + end if + case default + ierr(1) = 5; ierr(2) = reord_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + end if + + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_i2msort + +subroutine psi_i2_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) > k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine psi_i2_msort_up + +subroutine psi_i2_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) < k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine psi_i2_msort_dw + +subroutine psi_i2_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) > abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine psi_i2_amsort_up + +subroutine psi_i2_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) < abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + +end subroutine psi_i2_amsort_dw + + diff --git a/base/serial/sort/psb_i2_qsort_impl.f90 b/base/serial/sort/psb_i2_qsort_impl.f90 new file mode 100644 index 000000000..cc0ee95bb --- /dev/null +++ b/base/serial/sort/psb_i2_qsort_impl.f90 @@ -0,0 +1,1472 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +function psb_i2bsrch(key,n,v,dir,find) result(ipos) + use psb_sort_mod, psb_protect_name => psb_i2bsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_i2pk_) :: key + integer(psb_i2pk_) :: v(:) + integer(psb_ipk_), optional :: dir, find + + integer(psb_ipk_) :: lb, ub, m, i, k, dir_, find_ + + if (present(dir)) then + dir_ = dir + else + dir_ = psb_sort_up_ + end if + if (present(find)) then + find_ = find + else + find_ = psb_find_any_ + end if + + ipos = -1 + if (dir_ == psb_sort_up_) then + if (n<=5) then + do m=1,n + if (key == v(m)) then + ipos = m + exit + end if + enddo + + else + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + exit + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + end if + select case(find_) + case (psb_find_any_ ) + ! do nothing + case (psb_find_last_le_ ) + if ((m>n) .or. (m<1)) then + m = n + do while (m>=1) + if (v(m)<=key) exit + m = m - 1 + end do + else + do while (mn) .or. (m<1)) then + m = 1 + do while (m<=n) + if (v(m)>=key) exit + m = m + 1 + end do + else + do while (m>1) + if (v(m-1)>=key) then + m=m-1 + else + exit + end if + end do + end if + ipos = max(m,1) + + case default + write(0,*) 'Wrong FIND' + end select + + + else if (dir_ == psb_sort_down_) then + write(0,*) ' bsrch on sort down not implemented' + else + write(0,*) ' bsrch wrong DIR ',dir_,psb_sort_up_,psb_sort_down_ + end if + return +end function psb_i2bsrch + +function psb_i2ssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_i2ssrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_i2pk_) :: key + integer(psb_i2pk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return +end function psb_i2ssrch + +subroutine psb_i2qsort(x,ix,dir,flag,reord) + use psb_sort_mod, psb_protect_name => psb_i2qsort + use psb_error_mod + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag,reord + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act, i, reord_ + integer(psb_ipk_) :: n + integer(psb_i2pk_), allocatable :: tx(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_i2qsort' + call psb_erractionsave(err_act) + + + if (present(reord)) then + reord_ = reord + else + reord_= psb_sort_reord_x_ + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(reord_) + case (psb_sort_reord_x_) + select case(dir_) + case (psb_sort_up_) + call psi_i2qsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_i2qsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_i2aqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_i2aqsrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + case(psb_sort_noreord_x_) + tx = x + select case(dir_) + case (psb_sort_up_) + call psi_i2qsrx_up(n,tx,ix) + case (psb_sort_down_) + call psi_i2qsrx_dw(n,tx,ix) + case (psb_asort_up_) + call psi_i2aqsrx_up(n,tx,ix) + case (psb_asort_down_) + call psi_i2aqsrx_dw(n,tx,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + end select + else + select case(reord_) + case (psb_sort_reord_x_) + !OK + case default + ierr(1) = 5; ierr(2) = reord_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + select case(dir_) + case (psb_sort_up_) + call psi_i2qsr_up(n,x) + case (psb_sort_down_) + call psi_i2qsr_dw(n,x) + case (psb_asort_up_) + call psi_i2aqsr_up(n,x) + case (psb_asort_down_) + call psi_i2aqsr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_i2qsort + +subroutine psi_i2qsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2qsrx_up + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_i2qsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_i2isrx_up(n,x,idx) + endif +end subroutine psi_i2qsrx_up + +subroutine psi_i2qsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2qsrx_dw + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_i2qsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_i2isrx_dw(n,x,idx) + endif + +end subroutine psi_i2qsrx_dw + +subroutine psi_i2qsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_i2qsr_up + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_i2qsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_i2isr_up(n,x) + endif + +end subroutine psi_i2qsr_up + +subroutine psi_i2qsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_i2qsr_dw + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_i2qsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2isr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2isr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_i2isr_dw(n,x) + endif + +end subroutine psi_i2qsr_dw + +subroutine psi_i2aqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2aqsrx_up + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xk + integer(psb_i2pk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_i2aqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_i2aisrx_up(n,x,idx) + endif + + +end subroutine psi_i2aqsrx_up + +subroutine psi_i2aqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_i2aqsrx_dw + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xk + integer(psb_i2pk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_i2aqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_i2aisrx_dw(n,x,idx) + endif + +end subroutine psi_i2aqsrx_dw + +subroutine psi_i2aqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_i2aqsr_up + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xk + integer(psb_i2pk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_i2qasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_i2aisr_up(n,x) + endif + +end subroutine psi_i2aqsr_up + +subroutine psi_i2aqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_i2aqsr_dw + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_i2pk_) :: piv, xk + integer(psb_i2pk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_i2qasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_i2aisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_i2aisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_i2aisr_dw(n,x) + endif + +end subroutine psi_i2aqsr_dw + + diff --git a/base/serial/sort/psb_m_hsort_impl.f90 b/base/serial/sort/psb_m_hsort_impl.f90 index 92f67d8b0..743fe0381 100644 --- a/base/serial/sort/psb_m_hsort_impl.f90 +++ b/base/serial/sort/psb_m_hsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_m_isort_impl.f90 b/base/serial/sort/psb_m_isort_impl.f90 index ae6c0ce23..3d2001dc0 100644 --- a/base/serial/sort/psb_m_isort_impl.f90 +++ b/base/serial/sort/psb_m_isort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_m_msort_impl.f90 b/base/serial/sort/psb_m_msort_impl.f90 index d3af46737..69de7cc6e 100644 --- a/base/serial/sort/psb_m_msort_impl.f90 +++ b/base/serial/sort/psb_m_msort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this - ! software without specific written permission. + ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_m_qsort_impl.f90 b/base/serial/sort/psb_m_qsort_impl.f90 index 2dd009b3d..112f5db0d 100644 --- a/base/serial/sort/psb_m_qsort_impl.f90 +++ b/base/serial/sort/psb_m_qsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_s_hsort_impl.f90 b/base/serial/sort/psb_s_hsort_impl.f90 index 559f92c51..3e0a5a7f7 100644 --- a/base/serial/sort/psb_s_hsort_impl.f90 +++ b/base/serial/sort/psb_s_hsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_s_isort_impl.f90 b/base/serial/sort/psb_s_isort_impl.f90 index a8be6d46c..048ed943a 100644 --- a/base/serial/sort/psb_s_isort_impl.f90 +++ b/base/serial/sort/psb_s_isort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_s_msort_impl.f90 b/base/serial/sort/psb_s_msort_impl.f90 index e3c0a1845..a602cb34a 100644 --- a/base/serial/sort/psb_s_msort_impl.f90 +++ b/base/serial/sort/psb_s_msort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this - ! software without specific written permission. + ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_s_qsort_impl.f90 b/base/serial/sort/psb_s_qsort_impl.f90 index 6b2d48218..e0868ce4b 100644 --- a/base/serial/sort/psb_s_qsort_impl.f90 +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_z_hsort_impl.f90 b/base/serial/sort/psb_z_hsort_impl.f90 index 9e886dde9..018ede744 100644 --- a/base/serial/sort/psb_z_hsort_impl.f90 +++ b/base/serial/sort/psb_z_hsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_z_isort_impl.f90 b/base/serial/sort/psb_z_isort_impl.f90 index 465699dab..a7783925e 100644 --- a/base/serial/sort/psb_z_isort_impl.f90 +++ b/base/serial/sort/psb_z_isort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_z_msort_impl.f90 b/base/serial/sort/psb_z_msort_impl.f90 index 24934e14d..6eb8babe8 100644 --- a/base/serial/sort/psb_z_msort_impl.f90 +++ b/base/serial/sort/psb_z_msort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this - ! software without specific written permission. + ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/serial/sort/psb_z_qsort_impl.f90 b/base/serial/sort/psb_z_qsort_impl.f90 index ce3061ea9..6b9a7ca54 100644 --- a/base/serial/sort/psb_z_qsort_impl.f90 +++ b/base/serial/sort/psb_z_qsort_impl.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_c_glob_transpose.F90 b/base/tools/psb_c_glob_transpose.F90 index 8c8b3fd45..9285c18a0 100644 --- a/base/tools/psb_c_glob_transpose.F90 +++ b/base/tools/psb_c_glob_transpose.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_c_map.f90 b/base/tools/psb_c_map.f90 index 40ca3fe8c..6d11a7c94 100644 --- a/base/tools/psb_c_map.f90 +++ b/base/tools/psb_c_map.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,7 +71,7 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -91,7 +91,7 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_V%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,xt,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -115,19 +115,19 @@ end subroutine psb_c_map_U2V_a subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_c_map_U2V_v implicit none - class(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta - type(psb_c_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_clinmap_type), intent(in) :: map + complex(psb_spk_), intent(in) :: alpha,beta + type(psb_c_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_c_vect_type), target :: xt, yt - type(psb_c_vect_type),pointer :: ptx, pty - complex(psb_spk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& + type(psb_c_vect_type), target :: xt, yt + type(psb_c_vect_type),pointer :: ptx, pty + complex(psb_spk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_U2V_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_U2V_v' info = psb_success_ if (.not.map%is_asb()) then @@ -253,7 +253,7 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -273,7 +273,7 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_U%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,xt,czero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -296,19 +296,19 @@ end subroutine psb_c_map_V2U_a subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_c_map_V2U_v implicit none - class(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta - type(psb_c_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_clinmap_type), intent(in) :: map + complex(psb_spk_), intent(in) :: alpha,beta + type(psb_c_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_c_vect_type), target :: xt, yt - type(psb_c_vect_type),pointer :: ptx, pty - complex(psb_spk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& + type(psb_c_vect_type), target :: xt, yt + type(psb_c_vect_type),pointer :: ptx, pty + complex(psb_spk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_V2U_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_V2U_v' info = psb_success_ if (.not.map%is_asb()) then diff --git a/base/tools/psb_c_par_csr_spspmm.f90 b/base/tools/psb_c_par_csr_spspmm.f90 index 0d8e59899..de14df0c3 100644 --- a/base/tools/psb_c_par_csr_spspmm.f90 +++ b/base/tools/psb_c_par_csr_spspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_c_remap.F90 b/base/tools/psb_c_remap.F90 index ccab6c928..9b40dd29c 100644 --- a/base/tools/psb_c_remap.F90 +++ b/base/tools/psb_c_remap.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_c_remote_mat.F90 b/base/tools/psb_c_remote_mat.F90 index c3ef56022..ecfac5098 100644 --- a/base/tools/psb_c_remote_mat.F90 +++ b/base/tools/psb_c_remote_mat.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_c_remote_vect.F90 b/base/tools/psb_c_remote_vect.F90 index 855aea992..00e7415ae 100644 --- a/base/tools/psb_c_remote_vect.F90 +++ b/base/tools/psb_c_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index d42118720..f0d8f4203 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_callc_a.f90 b/base/tools/psb_callc_a.f90 index 5ae9dac5d..806f809d1 100644 --- a/base/tools/psb_callc_a.f90 +++ b/base/tools/psb_callc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_calloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index c8d2834c6..c72a43d3d 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -309,7 +309,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) dupl_ = x%get_dupl() if (scratch_) then call x%free(info) - call x%bld(ncol,n_,mold=mold) + call x%bld(ncol,n_,mold=mold,scratch=.true.) else call x%asb(ncol,n_,info) ! ..update halo elements.. diff --git a/base/tools/psb_casb_a.f90 b/base/tools/psb_casb_a.f90 index db7b23c8b..9fa846d87 100644 --- a/base/tools/psb_casb_a.f90 +++ b/base/tools/psb_casb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_casb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 index b9064212b..4f20bad67 100644 --- a/base/tools/psb_ccdbldext.F90 +++ b/base/tools/psb_ccdbldext.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index 54c728f59..524cdbe6b 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cfree_a.f90 b/base/tools/psb_cfree_a.f90 index a8746071a..85fa57c32 100644 --- a/base/tools/psb_cfree_a.f90 +++ b/base/tools/psb_cfree_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cgetelem.f90 b/base/tools/psb_cgetelem.f90 index 3c4151c9f..952ae251a 100644 --- a/base/tools/psb_cgetelem.f90 +++ b/base/tools/psb_cgetelem.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -108,3 +108,92 @@ function psb_c_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_c_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_cspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_c_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_c_getmatelem + use psi_mod + implicit none + + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + complex(psb_spk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = czero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_c_getmatelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = czero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index 1c14b7b27..be0655d49 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cins_a.f90 b/base/tools/psb_cins_a.f90 index 688d06e9f..bcd9e572f 100644 --- a/base/tools/psb_cins_a.f90 +++ b/base/tools/psb_cins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_cinsvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cspalloc.f90 b/base/tools/psb_cspalloc.f90 index 7bec040c3..afa2170ad 100644 --- a/base/tools/psb_cspalloc.f90 +++ b/base/tools/psb_cspalloc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index 1ada38e96..ac229b12c 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cspfree.f90 b/base/tools/psb_cspfree.f90 index 51f40259e..4a6aff419 100644 --- a/base/tools/psb_cspfree.f90 +++ b/base/tools/psb_cspfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 index cd053056b..1b6102548 100644 --- a/base/tools/psb_csphalo.F90 +++ b/base/tools/psb_csphalo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_cspins.F90 b/base/tools/psb_cspins.F90 index 6ed5c6296..4b40d4ce9 100644 --- a/base/tools/psb_cspins.F90 +++ b/base/tools/psb_cspins.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_csprn.f90 b/base/tools/psb_csprn.f90 index 82fb5be2f..eaeadf66d 100644 --- a/base/tools/psb_csprn.f90 +++ b/base/tools/psb_csprn.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_d_glob_transpose.F90 b/base/tools/psb_d_glob_transpose.F90 index 2fc4a4580..f884222f6 100644 --- a/base/tools/psb_d_glob_transpose.F90 +++ b/base/tools/psb_d_glob_transpose.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_d_map.f90 b/base/tools/psb_d_map.f90 index a36c07b36..9c009dbf1 100644 --- a/base/tools/psb_d_map.f90 +++ b/base/tools/psb_d_map.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,7 +71,7 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -91,7 +91,7 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_V%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_U2V,xt,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -115,19 +115,19 @@ end subroutine psb_d_map_U2V_a subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_d_map_U2V_v implicit none - class(psb_dlinmap_type), intent(in) :: map - real(psb_dpk_), intent(in) :: alpha,beta - type(psb_d_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_dlinmap_type), intent(in) :: map + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_d_vect_type), target :: xt, yt - type(psb_d_vect_type),pointer :: ptx, pty - real(psb_dpk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& + type(psb_d_vect_type), target :: xt, yt + type(psb_d_vect_type),pointer :: ptx, pty + real(psb_dpk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_U2V_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_U2V_v' info = psb_success_ if (.not.map%is_asb()) then @@ -253,7 +253,7 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -273,7 +273,7 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_U%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(done,map%mat_V2U,xt,dzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -296,19 +296,19 @@ end subroutine psb_d_map_V2U_a subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_d_map_V2U_v implicit none - class(psb_dlinmap_type), intent(in) :: map - real(psb_dpk_), intent(in) :: alpha,beta - type(psb_d_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_dlinmap_type), intent(in) :: map + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_d_vect_type), target :: xt, yt - type(psb_d_vect_type),pointer :: ptx, pty - real(psb_dpk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& + type(psb_d_vect_type), target :: xt, yt + type(psb_d_vect_type),pointer :: ptx, pty + real(psb_dpk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_V2U_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_V2U_v' info = psb_success_ if (.not.map%is_asb()) then diff --git a/base/tools/psb_d_par_csr_spspmm.f90 b/base/tools/psb_d_par_csr_spspmm.f90 index 3ab675615..3b0a8671c 100644 --- a/base/tools/psb_d_par_csr_spspmm.f90 +++ b/base/tools/psb_d_par_csr_spspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_d_remap.F90 b/base/tools/psb_d_remap.F90 index dc3219189..a2c9c291f 100644 --- a/base/tools/psb_d_remap.F90 +++ b/base/tools/psb_d_remap.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_d_remote_mat.F90 b/base/tools/psb_d_remote_mat.F90 index 095474699..56f7b3d3c 100644 --- a/base/tools/psb_d_remote_mat.F90 +++ b/base/tools/psb_d_remote_mat.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_d_remote_vect.F90 b/base/tools/psb_d_remote_vect.F90 index 78a089fd2..38ea57b6c 100644 --- a/base/tools/psb_d_remote_vect.F90 +++ b/base/tools/psb_d_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 8a02d3ad5..c726db862 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dallc_a.f90 b/base/tools/psb_dallc_a.f90 index 8cd927fe8..027b64a60 100644 --- a/base/tools/psb_dallc_a.f90 +++ b/base/tools/psb_dallc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_dalloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 74970cc76..a4b5a3e38 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -309,7 +309,7 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) dupl_ = x%get_dupl() if (scratch_) then call x%free(info) - call x%bld(ncol,n_,mold=mold) + call x%bld(ncol,n_,mold=mold,scratch=.true.) else call x%asb(ncol,n_,info) ! ..update halo elements.. diff --git a/base/tools/psb_dasb_a.f90 b/base/tools/psb_dasb_a.f90 index 2a62fedf8..305c2e31d 100644 --- a/base/tools/psb_dasb_a.f90 +++ b/base/tools/psb_dasb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_dasb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dcdbldext.F90 b/base/tools/psb_dcdbldext.F90 index d6721c764..f16402b7c 100644 --- a/base/tools/psb_dcdbldext.F90 +++ b/base/tools/psb_dcdbldext.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 8e092dfa3..e3c8482ec 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dfree_a.f90 b/base/tools/psb_dfree_a.f90 index 0ce49ecca..b71aba123 100644 --- a/base/tools/psb_dfree_a.f90 +++ b/base/tools/psb_dfree_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dgetelem.f90 b/base/tools/psb_dgetelem.f90 index 38d398aa8..805204b08 100644 --- a/base/tools/psb_dgetelem.f90 +++ b/base/tools/psb_dgetelem.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -108,3 +108,92 @@ function psb_d_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_d_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_dspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_d_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_d_getmatelem + use psi_mod + implicit none + + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + real(psb_dpk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = dzero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_d_getmatelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = dzero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index eca13da7c..3141ffc84 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dins_a.f90 b/base/tools/psb_dins_a.f90 index eb04ebaff..dd53275df 100644 --- a/base/tools/psb_dins_a.f90 +++ b/base/tools/psb_dins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_dinsvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index 433d71298..192267c83 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index 7f00d8bc1..f8e26a2a0 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dspfree.f90 b/base/tools/psb_dspfree.f90 index 060043487..9015907f2 100644 --- a/base/tools/psb_dspfree.f90 +++ b/base/tools/psb_dspfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dsphalo.F90 b/base/tools/psb_dsphalo.F90 index 53b671b2b..b40a7c514 100644 --- a/base/tools/psb_dsphalo.F90 +++ b/base/tools/psb_dsphalo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dspins.F90 b/base/tools/psb_dspins.F90 index a9cbbe4b6..e88be0840 100644 --- a/base/tools/psb_dspins.F90 +++ b/base/tools/psb_dspins.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_dsprn.f90 b/base/tools/psb_dsprn.f90 index 36e0531f4..a3b613a3f 100644 --- a/base/tools/psb_dsprn.f90 +++ b/base/tools/psb_dsprn.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_e_remote_vect.F90 b/base/tools/psb_e_remote_vect.F90 index 0ca38c022..91423486f 100644 --- a/base/tools/psb_e_remote_vect.F90 +++ b/base/tools/psb_e_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_eallc_a.f90 b/base/tools/psb_eallc_a.f90 index c9c65634d..ba1a60338 100644 --- a/base/tools/psb_eallc_a.f90 +++ b/base/tools/psb_eallc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_ealloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_easb_a.f90 b/base/tools/psb_easb_a.f90 index baa8514d3..e0819bc2b 100644 --- a/base/tools/psb_easb_a.f90 +++ b/base/tools/psb_easb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_easb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_efree_a.f90 b/base/tools/psb_efree_a.f90 index 85baa0c0c..9439f65b2 100644 --- a/base/tools/psb_efree_a.f90 +++ b/base/tools/psb_efree_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_eins_a.f90 b/base/tools/psb_eins_a.f90 index 25744f5ad..3db771844 100644 --- a/base/tools/psb_eins_a.f90 +++ b/base/tools/psb_eins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_einsvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_i2_remote_vect.F90 b/base/tools/psb_i2_remote_vect.F90 index 4c4ce8b54..c2a7706f3 100644 --- a/base/tools/psb_i2_remote_vect.F90 +++ b/base/tools/psb_i2_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_i2allc_a.f90 b/base/tools/psb_i2allc_a.f90 index 525983041..55c152152 100644 --- a/base/tools/psb_i2allc_a.f90 +++ b/base/tools/psb_i2allc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_i2alloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_i2asb_a.f90 b/base/tools/psb_i2asb_a.f90 index 97879105f..397703452 100644 --- a/base/tools/psb_i2asb_a.f90 +++ b/base/tools/psb_i2asb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_i2asb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_i2free_a.f90 b/base/tools/psb_i2free_a.f90 index d5c7509ca..1aa9c9c06 100644 --- a/base/tools/psb_i2free_a.f90 +++ b/base/tools/psb_i2free_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_i2ins_a.f90 b/base/tools/psb_i2ins_a.f90 index 975e619b2..81e321baf 100644 --- a/base/tools/psb_i2ins_a.f90 +++ b/base/tools/psb_i2ins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_i2insvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 68b94e59e..6ecb6d270 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 474b8934c..b962b28ec 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -309,7 +309,7 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) dupl_ = x%get_dupl() if (scratch_) then call x%free(info) - call x%bld(ncol,n_,mold=mold) + call x%bld(ncol,n_,mold=mold,scratch=.true.) else call x%asb(ncol,n_,info) ! ..update halo elements.. diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index a804913a3..7e0d67587 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index bf02deb19..bbe666ed6 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index ba8cc415e..8d3767989 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 index 3f0ba4670..c9dba3ab6 100644 --- a/base/tools/psb_lasb.f90 +++ b/base/tools/psb_lasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -309,7 +309,7 @@ subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n) dupl_ = x%get_dupl() if (scratch_) then call x%free(info) - call x%bld(ncol,n_,mold=mold) + call x%bld(ncol,n_,mold=mold,scratch=.true.) else call x%asb(ncol,n_,info) ! ..update halo elements.. diff --git a/base/tools/psb_lfree.f90 b/base/tools/psb_lfree.f90 index 6630601c0..42c28eb25 100644 --- a/base/tools/psb_lfree.f90 +++ b/base/tools/psb_lfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 index a3548571e..1070173d1 100644 --- a/base/tools/psb_lins.f90 +++ b/base/tools/psb_lins.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_m_remote_vect.F90 b/base/tools/psb_m_remote_vect.F90 index 2266cc800..94cbba4dc 100644 --- a/base/tools/psb_m_remote_vect.F90 +++ b/base/tools/psb_m_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_mallc_a.f90 b/base/tools/psb_mallc_a.f90 index c815e8f93..0f67dda4b 100644 --- a/base/tools/psb_mallc_a.f90 +++ b/base/tools/psb_mallc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_malloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_masb_a.f90 b/base/tools/psb_masb_a.f90 index 50f2b7685..46c3ccd44 100644 --- a/base/tools/psb_masb_a.f90 +++ b/base/tools/psb_masb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_masb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_mfree_a.f90 b/base/tools/psb_mfree_a.f90 index c2f57f216..5beae30ca 100644 --- a/base/tools/psb_mfree_a.f90 +++ b/base/tools/psb_mfree_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_mins_a.f90 b/base/tools/psb_mins_a.f90 index d1549c921..7af8a44d2 100644 --- a/base/tools/psb_mins_a.f90 +++ b/base/tools/psb_mins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_minsvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_s_glob_transpose.F90 b/base/tools/psb_s_glob_transpose.F90 index d663ea3e5..bee763ac0 100644 --- a/base/tools/psb_s_glob_transpose.F90 +++ b/base/tools/psb_s_glob_transpose.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_s_map.f90 b/base/tools/psb_s_map.f90 index 47faf8c7a..8cd31e10f 100644 --- a/base/tools/psb_s_map.f90 +++ b/base/tools/psb_s_map.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,7 +71,7 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -91,7 +91,7 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_V%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,xt,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -115,19 +115,19 @@ end subroutine psb_s_map_U2V_a subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_s_map_U2V_v implicit none - class(psb_slinmap_type), intent(in) :: map - real(psb_spk_), intent(in) :: alpha,beta - type(psb_s_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_slinmap_type), intent(in) :: map + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_s_vect_type), target :: xt, yt - type(psb_s_vect_type),pointer :: ptx, pty - real(psb_spk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& + type(psb_s_vect_type), target :: xt, yt + type(psb_s_vect_type),pointer :: ptx, pty + real(psb_spk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_U2V_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_U2V_v' info = psb_success_ if (.not.map%is_asb()) then @@ -253,7 +253,7 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -273,7 +273,7 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_U%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,xt,szero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -296,19 +296,19 @@ end subroutine psb_s_map_V2U_a subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_s_map_V2U_v implicit none - class(psb_slinmap_type), intent(in) :: map - real(psb_spk_), intent(in) :: alpha,beta - type(psb_s_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_slinmap_type), intent(in) :: map + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_s_vect_type), target :: xt, yt - type(psb_s_vect_type),pointer :: ptx, pty - real(psb_spk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& + type(psb_s_vect_type), target :: xt, yt + type(psb_s_vect_type),pointer :: ptx, pty + real(psb_spk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_V2U_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_V2U_v' info = psb_success_ if (.not.map%is_asb()) then diff --git a/base/tools/psb_s_par_csr_spspmm.f90 b/base/tools/psb_s_par_csr_spspmm.f90 index 17bf4e449..ca21351a0 100644 --- a/base/tools/psb_s_par_csr_spspmm.f90 +++ b/base/tools/psb_s_par_csr_spspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_s_remap.F90 b/base/tools/psb_s_remap.F90 index b7cf73696..6f5365b32 100644 --- a/base/tools/psb_s_remap.F90 +++ b/base/tools/psb_s_remap.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_s_remote_mat.F90 b/base/tools/psb_s_remote_mat.F90 index 631777ecf..a9bc2a7a5 100644 --- a/base/tools/psb_s_remote_mat.F90 +++ b/base/tools/psb_s_remote_mat.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_s_remote_vect.F90 b/base/tools/psb_s_remote_vect.F90 index 260d03bd2..cd7fe19ea 100644 --- a/base/tools/psb_s_remote_vect.F90 +++ b/base/tools/psb_s_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 3c4f9a993..518b269dd 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sallc_a.f90 b/base/tools/psb_sallc_a.f90 index 3b511d61b..9a50199fd 100644 --- a/base/tools/psb_sallc_a.f90 +++ b/base/tools/psb_sallc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_salloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 6d667dc96..24670a0e9 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -309,7 +309,7 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) dupl_ = x%get_dupl() if (scratch_) then call x%free(info) - call x%bld(ncol,n_,mold=mold) + call x%bld(ncol,n_,mold=mold,scratch=.true.) else call x%asb(ncol,n_,info) ! ..update halo elements.. diff --git a/base/tools/psb_sasb_a.f90 b/base/tools/psb_sasb_a.f90 index 76dbdafbe..a6a4ef347 100644 --- a/base/tools/psb_sasb_a.f90 +++ b/base/tools/psb_sasb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_sasb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 index 812ca8aa0..d7a5f7223 100644 --- a/base/tools/psb_scdbldext.F90 +++ b/base/tools/psb_scdbldext.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index add6162b5..90c397c28 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sfree_a.f90 b/base/tools/psb_sfree_a.f90 index 036bb903c..b8f1e7c7f 100644 --- a/base/tools/psb_sfree_a.f90 +++ b/base/tools/psb_sfree_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sgetelem.f90 b/base/tools/psb_sgetelem.f90 index 723a2f7df..73ab33efa 100644 --- a/base/tools/psb_sgetelem.f90 +++ b/base/tools/psb_sgetelem.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -108,3 +108,92 @@ function psb_s_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_s_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_sspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_s_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_s_getmatelem + use psi_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + real(psb_spk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = szero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_s_getmatelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = szero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index ec9988f8b..bc3a73db0 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sins_a.f90 b/base/tools/psb_sins_a.f90 index 629ad7832..d1e8db110 100644 --- a/base/tools/psb_sins_a.f90 +++ b/base/tools/psb_sins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_sinsvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sspalloc.f90 b/base/tools/psb_sspalloc.f90 index 8004e7421..3e421d5a3 100644 --- a/base/tools/psb_sspalloc.f90 +++ b/base/tools/psb_sspalloc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index 60d1c25f8..971efe06c 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sspfree.f90 b/base/tools/psb_sspfree.f90 index 968e9f9a6..073f8cdc6 100644 --- a/base/tools/psb_sspfree.f90 +++ b/base/tools/psb_sspfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 index 9a94b4383..c33a560b7 100644 --- a/base/tools/psb_ssphalo.F90 +++ b/base/tools/psb_ssphalo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_sspins.F90 b/base/tools/psb_sspins.F90 index 377c6e23a..74497707f 100644 --- a/base/tools/psb_sspins.F90 +++ b/base/tools/psb_sspins.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_ssprn.f90 b/base/tools/psb_ssprn.f90 index 602867e67..6b687306f 100644 --- a/base/tools/psb_ssprn.f90 +++ b/base/tools/psb_ssprn.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_z_glob_transpose.F90 b/base/tools/psb_z_glob_transpose.F90 index de952682d..339d2804e 100644 --- a/base/tools/psb_z_glob_transpose.F90 +++ b/base/tools/psb_z_glob_transpose.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_z_map.f90 b/base/tools/psb_z_map.f90 index 55500f583..e7c8a7409 100644 --- a/base/tools/psb_z_map.f90 +++ b/base/tools/psb_z_map.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -71,7 +71,7 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_V%get_global_rows() nc2 = map%p_desc_V%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -91,7 +91,7 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_V%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,xt,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then call psb_sum(ctxt,yt(1:nr2)) @@ -115,19 +115,19 @@ end subroutine psb_z_map_U2V_a subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_z_map_U2V_v implicit none - class(psb_zlinmap_type), intent(in) :: map - complex(psb_dpk_), intent(in) :: alpha,beta - type(psb_z_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_zlinmap_type), intent(in) :: map + complex(psb_dpk_), intent(in) :: alpha,beta + type(psb_z_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_z_vect_type), target :: xt, yt - type(psb_z_vect_type),pointer :: ptx, pty - complex(psb_dpk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& + type(psb_z_vect_type), target :: xt, yt + type(psb_z_vect_type),pointer :: ptx, pty + complex(psb_dpk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2 ,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_U2V_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_U2V_v' info = psb_success_ if (.not.map%is_asb()) then @@ -253,7 +253,7 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work) nr2 = map%p_desc_U%get_global_rows() nc2 = map%p_desc_U%get_local_cols() allocate(yt(nc2),stat=info) - if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work) + if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -273,7 +273,7 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work) nc2 = map%desc_U%get_local_cols() allocate(xt(nc1),yt(nc2),stat=info) xt(1:nr1) = x(1:nr1) - if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work) + if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work) if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,xt,zzero,yt,info) if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then call psb_sum(ctxt,yt(1:nr2)) @@ -296,19 +296,19 @@ end subroutine psb_z_map_V2U_a subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty) use psb_base_mod, psb_protect_name => psb_z_map_V2U_v implicit none - class(psb_zlinmap_type), intent(in) :: map - complex(psb_dpk_), intent(in) :: alpha,beta - type(psb_z_vect_type), intent(inout) :: x,y - integer(psb_ipk_), intent(out) :: info + class(psb_zlinmap_type), intent(in) :: map + complex(psb_dpk_), intent(in) :: alpha,beta + type(psb_z_vect_type), intent(inout) :: x,y + integer(psb_ipk_), intent(out) :: info type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty ! Local - type(psb_z_vect_type), target :: xt, yt - type(psb_z_vect_type),pointer :: ptx, pty - complex(psb_dpk_), allocatable :: xta(:), yta(:) - integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& + type(psb_z_vect_type), target :: xt, yt + type(psb_z_vect_type),pointer :: ptx, pty + complex(psb_dpk_), allocatable :: xta(:), yta(:) + integer(psb_ipk_) :: i, j, nr1, nc1,nr2, nc2,& & map_kind, nr, iam, np - type(psb_ctxt_type) :: ctxt - character(len=20), parameter :: name='psb_map_V2U_v' + type(psb_ctxt_type) :: ctxt + character(len=20), parameter :: name = 'psb_map_V2U_v' info = psb_success_ if (.not.map%is_asb()) then diff --git a/base/tools/psb_z_par_csr_spspmm.f90 b/base/tools/psb_z_par_csr_spspmm.f90 index 6629aee25..455d2128f 100644 --- a/base/tools/psb_z_par_csr_spspmm.f90 +++ b/base/tools/psb_z_par_csr_spspmm.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_z_remap.F90 b/base/tools/psb_z_remap.F90 index 661ae3cc9..c8d23a600 100644 --- a/base/tools/psb_z_remap.F90 +++ b/base/tools/psb_z_remap.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_z_remote_mat.F90 b/base/tools/psb_z_remote_mat.F90 index 5542f2260..c30f7896f 100644 --- a/base/tools/psb_z_remote_mat.F90 +++ b/base/tools/psb_z_remote_mat.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_z_remote_vect.F90 b/base/tools/psb_z_remote_vect.F90 index 319ab38fd..083d23d7e 100644 --- a/base/tools/psb_z_remote_vect.F90 +++ b/base/tools/psb_z_remote_vect.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index bfc3d6780..a3ffa1ee7 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zallc_a.f90 b/base/tools/psb_zallc_a.f90 index 1af815e4a..a9fe74fd8 100644 --- a/base/tools/psb_zallc_a.f90 +++ b/base/tools/psb_zallc_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -147,7 +147,7 @@ end subroutine psb_zalloc !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index b8d797ecc..9e516dbce 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -309,7 +309,7 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) dupl_ = x%get_dupl() if (scratch_) then call x%free(info) - call x%bld(ncol,n_,mold=mold) + call x%bld(ncol,n_,mold=mold,scratch=.true.) else call x%asb(ncol,n_,info) ! ..update halo elements.. diff --git a/base/tools/psb_zasb_a.f90 b/base/tools/psb_zasb_a.f90 index e8c9db992..1d6cae4da 100644 --- a/base/tools/psb_zasb_a.f90 +++ b/base/tools/psb_zasb_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -153,7 +153,7 @@ end subroutine psb_zasb !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zcdbldext.F90 b/base/tools/psb_zcdbldext.F90 index 0db84d7a0..fe83b784d 100644 --- a/base/tools/psb_zcdbldext.F90 +++ b/base/tools/psb_zcdbldext.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index 6f7f057b1..862432f42 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zfree_a.f90 b/base/tools/psb_zfree_a.f90 index 95fa38d14..67e94de19 100644 --- a/base/tools/psb_zfree_a.f90 +++ b/base/tools/psb_zfree_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zgetelem.f90 b/base/tools/psb_zgetelem.f90 index ac130e826..a4cb114be 100644 --- a/base/tools/psb_zgetelem.f90 +++ b/base/tools/psb_zgetelem.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -108,3 +108,92 @@ function psb_z_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_z_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_zspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_z_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_z_getmatelem + use psi_mod + implicit none + + type(psb_zspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + complex(psb_dpk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = zzero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_z_getmatelem' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = zzero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 8e8b2afd0..a966c0130 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zins_a.f90 b/base/tools/psb_zins_a.f90 index 4b068117f..7bd8b1f9c 100644 --- a/base/tools/psb_zins_a.f90 +++ b/base/tools/psb_zins_a.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -195,7 +195,7 @@ end subroutine psb_zinsvi !!$ documentation and/or other materials provided with the distribution. !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. +!!$ software without specific prior written permission. !!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index 308774ef8..58a71b85c 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index deba9edc2..163f0d5e5 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index 73f0bb273..3d89e4cbd 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zsphalo.F90 b/base/tools/psb_zsphalo.F90 index 3a878172d..90151d451 100644 --- a/base/tools/psb_zsphalo.F90 +++ b/base/tools/psb_zsphalo.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zspins.F90 b/base/tools/psb_zspins.F90 index f5181030b..2e73b7ae4 100644 --- a/base/tools/psb_zspins.F90 +++ b/base/tools/psb_zspins.F90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED diff --git a/base/tools/psb_zsprn.f90 b/base/tools/psb_zsprn.f90 index c1676bed0..0d797d482 100644 --- a/base/tools/psb_zsprn.f90 +++ b/base/tools/psb_zsprn.f90 @@ -14,7 +14,7 @@ ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this -! software without specific written permission. +! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED