From 899c425d01164658fe1e78eddea83ee081a81097 Mon Sep 17 00:00:00 2001 From: Stack-1 Date: Mon, 16 Mar 2026 12:34:05 +0100 Subject: [PATCH] [UPDATE] Mid update used to merge communication and fixmpic --- base/CMakeLists.txt | 8 - base/comm/Makefile | 4 +- base/comm/internals/psi_dswapdata.F90 | 310 ++++++++++++++-- base/comm/internals/psi_dswapdata_a.F90 | 51 ++- base/comm/psb_dhalo.f90 | 83 ++--- base/comm/psb_dhalo_a.f90 | 45 +-- base/comm/psb_dhalo_a_new.f90 | 390 -------------------- base/comm/psb_dhalo_new.F90 | 298 --------------- base/modules/comm/psb_c_comm_a_mod.f90 | 26 -- base/modules/comm/psb_c_comm_mod.f90 | 25 -- base/modules/comm/psb_d_comm_a_mod.f90 | 45 +-- base/modules/comm/psb_d_comm_mod.f90 | 34 +- base/modules/comm/psb_s_comm_a_mod.f90 | 26 -- base/modules/comm/psb_s_comm_mod.f90 | 25 -- base/modules/comm/psb_z_comm_mod.f90 | 25 -- base/modules/comm/psi_d_comm_a_mod.f90 | 39 +- base/modules/comm/psi_d_comm_v_mod.f90 | 11 + base/modules/desc/psb_desc_mod.F90 | 99 ++++- base/modules/psb_const_mod.F90 | 9 +- base/modules/serial/psb_d_base_vect_mod.F90 | 36 ++ cbind/psb_c_base.h | 149 -------- cbind/psb_c_cbase.h | 109 ------ cbind/psb_c_dbase.h | 113 ------ cbind/psb_c_sbase.h | 110 ------ cbind/psb_c_zbase.h | 110 ------ test/halo_new/Makefile | 9 +- test/halo_new/test_halo_new.F90 | 125 ++++--- test/halo_new/test_halo_new_api.F90 | 285 ++++++++++++++ 28 files changed, 911 insertions(+), 1688 deletions(-) delete mode 100644 base/comm/psb_dhalo_a_new.f90 delete mode 100644 base/comm/psb_dhalo_new.F90 delete mode 100644 cbind/psb_c_base.h delete mode 100644 cbind/psb_c_cbase.h delete mode 100644 cbind/psb_c_dbase.h delete mode 100644 cbind/psb_c_sbase.h delete mode 100644 cbind/psb_c_zbase.h create mode 100644 test/halo_new/test_halo_new_api.F90 diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 5fa6bdf6..437d7c0f 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -68,32 +68,26 @@ set(PSB_base_source_files comm/internals/psi_cswaptran_a.F90 comm/internals/psi_sovrl_restr.f90 comm/psb_dhalo.f90 - comm/psb_dhalo_new.f90 comm/psb_zgather_a.f90 comm/psb_zovrl.f90 comm/psb_mhalo_a.f90 comm/psb_zscatter_a.F90 comm/psb_chalo.f90 - comm/psb_chalo_new.f90 comm/psb_zscatter.F90 comm/psb_cscatter_a.F90 comm/psb_cspgather.F90 comm/psb_cscatter.F90 comm/psb_shalo_a.f90 - comm/psb_shalo_a_new.f90 comm/psb_cgather.f90 comm/psb_zhalo.f90 - comm/psb_zhalo_new.f90 comm/psb_movrl_a.f90 comm/psb_chalo_a.f90 - comm/psb_chalo_a_new.f90 # comm/psb_i2scatter_a.F90 comm/psb_sgather_a.f90 # comm/psb_i2ovrl_a.f90 comm/psb_zovrl_a.f90 comm/psb_covrl.f90 comm/psb_shalo.f90 - comm/psb_shalo_new.f90 comm/psb_dscatter_a.F90 comm/psb_lgather.f90 comm/psb_iscatter.F90 @@ -104,7 +98,6 @@ set(PSB_base_source_files ## comm/psb_lspgather.F90 ## comm/psb_ispgather.F90 comm/psb_zhalo_a.f90 - comm/psb_zhalo_a_new.f90 comm/psb_sscatter_a.F90 comm/psb_lscatter.F90 # comm/psb_i2gather_a.f90 @@ -117,7 +110,6 @@ set(PSB_base_source_files comm/psb_covrl_a.f90 comm/psb_sgather.f90 comm/psb_dhalo_a.f90 - comm/psb_dhalo_a_new.f90 comm/psb_zgather.f90 comm/psb_igather.f90 comm/psb_sovrl.f90 diff --git a/base/comm/Makefile b/base/comm/Makefile index 46e6737b..dfa1bed8 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -1,12 +1,12 @@ include ../../Make.inc -OBJS = psb_dgather.o psb_dhalo.o psb_dhalo_new.o psb_dovrl.o \ +OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ psb_sgather.o psb_shalo.o psb_sovrl.o \ psb_igather.o psb_ihalo.o psb_iovrl.o \ psb_lgather.o psb_lhalo.o psb_lovrl.o \ psb_cgather.o psb_chalo.o psb_covrl.o \ psb_zgather.o psb_zhalo.o psb_zovrl.o \ - psb_dgather_a.o psb_dhalo_a.o psb_dhalo_a_new.o psb_dovrl_a.o \ + psb_dgather_a.o psb_dhalo_a.o psb_dovrl_a.o \ psb_sgather_a.o psb_shalo_a.o psb_sovrl_a.o \ psb_mgather_a.o psb_mhalo_a.o psb_movrl_a.o \ psb_egather_a.o psb_ehalo_a.o psb_eovrl_a.o \ diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index a7eccf88..fbda484d 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -160,8 +160,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) return -end subroutine psi_dswapdata_vect - +contains ! @@ -181,7 +180,6 @@ end subroutine psi_dswapdata_vect ! subroutine psi_dswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_dswap_vidx_vect use psb_error_mod use psb_realloc_mod use psb_desc_mod @@ -276,7 +274,6 @@ end subroutine psi_dswap_vidx_vect subroutine psi_dswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_dswap_baseline_vect use psb_d_base_vect_mod use psb_error_mod use psb_desc_mod @@ -518,9 +515,10 @@ subroutine psi_dswap_baseline_vect(ctxt,icomm,flag,beta,y,idx, & end subroutine psi_dswap_baseline_vect + + subroutine psi_dswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_dswap_neighbor_topology_vect use psb_d_base_vect_mod use psb_error_mod use psb_desc_mod @@ -682,6 +680,7 @@ subroutine psi_dswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx, & return end subroutine psi_dswap_neighbor_topology_vect +end subroutine psi_dswapdata_vect ! ! @@ -761,7 +760,6 @@ subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dswapdata_multivect ! @@ -779,13 +777,104 @@ end subroutine psi_dswapdata_multivect ! subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & & totxch,totsnd,totrcv,work,info) + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_d_base_multivect_mod + use psb_neighbor_topology_mod + +#ifdef PSB_MPI_MOD + use mpi +#endif + implicit none +#ifdef PSB_MPI_H + include 'mpif.h' +#endif + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! local variables used to detect the communication scheme + logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait + logical :: baseline, neighbor_a2av + + ! error handling variables + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: me, np + character(len=20) :: name + + + info=psb_success_ + name='psi_dswap_vidx_multivect' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + swap_start = iand(flag,psb_swap_start_) /= 0 + swap_wait = iand(flag,psb_swap_wait_) /= 0 + + baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync + neighbor_a2av = swap_start .or. swap_wait + + if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') + goto 9999 + end if + + + if (baseline) then + call psi_dswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + else if (neighbor_a2av) then + call psi_dswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av swap') + 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) - use psi_mod, psb_protect_name => psi_dswap_vidx_multivect + return + +end subroutine psi_dswap_vidx_multivect + +subroutine psi_dswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) use psb_error_mod use psb_realloc_mod use psb_desc_mod use psb_penv_mod use psb_d_base_multivect_mod + use psb_neighbor_topology_mod + #ifdef PSB_MPI_MOD use mpi #endif @@ -794,33 +883,33 @@ subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_multivect_type) :: y - real(psb_dpk_), intent(in) :: beta - real(psb_dpk_), target :: work(:) - 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_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name - info=psb_success_ - name='psi_swap_datav' + info = psb_success_ + name = 'psi_dswap_baseline_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 @@ -1024,7 +1113,174 @@ subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dswap_vidx_multivect +end subroutine psi_dswap_baseline_vidx_multivect + + + +subroutine psi_dswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + use psi_mod, psb_protect_name => psi_dswap_neighbor_topology_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_d_base_multivect_mod + use psb_neighbor_topology_mod + +#ifdef PSB_MPI_MOD + use mpi +#endif + implicit none +#ifdef PSB_MPI_H + include 'mpif.h' +#endif + + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: icomm + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_), intent(in) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: 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_dswap_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 + + 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, totxch, totsnd, totrcv, & + & 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 + + ! 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 + 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_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 + 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 + ! 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 + + ! 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 + + ! 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 + 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_dswap_neighbor_topology_multivect + +end subroutine psi_dswapdata_multivect diff --git a/base/comm/internals/psi_dswapdata_a.F90 b/base/comm/internals/psi_dswapdata_a.F90 index 6c370b82..57ca4a15 100644 --- a/base/comm/internals/psi_dswapdata_a.F90 +++ b/base/comm/internals/psi_dswapdata_a.F90 @@ -98,37 +98,37 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info = psb_success_ + name = 'psi_dswapdatam' call psb_erractionsave(err_act) ctxt = desc_a%get_context() icomm = desc_a%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 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 @@ -158,7 +158,6 @@ end subroutine psi_dswapdatam subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, & & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_dswapidxm use psb_error_mod use psb_desc_mod @@ -176,9 +175,9 @@ subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, & integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv ! locals @@ -198,8 +197,8 @@ subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, & #endif character(len=20) :: name - info=psb_success_ - name='psi_swap_data' + info = psb_success_ + name = 'psi_dswapidxm' call psb_erractionsave(err_act) call psb_info(ctxt,me,np) if (np == -1) then @@ -288,8 +287,8 @@ subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, & idx_pt = 1+pnti+nerv+psb_n_elem_send_ call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + snd_pt = snd_pt + nrv*nesd + pnti = pnti + ne + nesd + 3 end do end if diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index 080631e1..954c2518 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -52,36 +52,37 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) +subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_dhalo_vect use psi_mod + implicit none - type(psb_d_vect_type), intent(inout) :: x - type(psb_desc_type), intent(in) :: desc_a + type(psb_d_vect_type), 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(:) + real(psb_dpk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran + 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, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx - real(psb_dpk_),pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw + real(psb_dpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw - name='psb_dhalov' - info=psb_success_ + name = 'psb_dhalo_vect' + info = psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then info = psb_err_internal_error_ ; goto 9999 end if - ctxt=desc_a%get_context() + ctxt = desc_a%get_context() ! check on blacs grid call psb_info(ctxt, me, np) @@ -118,13 +119,14 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = desc_a%get_communication_mode() endif if ((info == 0).and.(lldx psb_dhalom use psi_mod 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_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, k - integer(psb_ipk_) :: err_act, iix, jjx, maxk, nrow, imode, i,& + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, k + integer(psb_ipk_) :: err_act, iix, jjx, maxk, nrow, imode, i,& & liwork,data_, ldx - integer(psb_lpk_) :: m, n, ix, ijx - real(psb_dpk_),pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dhalom' - info=psb_success_ + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_dpk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name = 'psb_dhalom' + 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) @@ -123,7 +124,7 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = desc_a%get_communication_mode() endif if (present(data)) then @@ -313,7 +314,7 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) if (present(mode)) then imode = mode else - imode = IOR(psb_swap_send_,psb_swap_recv_) + imode = desc_a%get_communication_mode() endif ldx = size(x,1) ! check vector correctness diff --git a/base/comm/psb_dhalo_a_new.f90 b/base/comm/psb_dhalo_a_new.f90 deleted file mode 100644 index 33b58608..00000000 --- a/base/comm/psb_dhalo_a_new.f90 +++ /dev/null @@ -1,390 +0,0 @@ -! -! 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 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. -! -! -! File: psb_dhalo_a_new.f90 -! -! Subroutine: psb_dhalom_new -! This subroutine performs the exchange of the halo elements in a -! distributed dense matrix between all the processes. -! The comm_type argument selects the communication scheme: -! psb_comm_type_isend_ (0) = classic irecv/send (default) -! psb_comm_type_neigh_a2av_ (1) = MPI_Alltoallv collective -! -! Arguments: -! x - real,dimension(:,:). The local part of the dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! comm_type - integer. Communication scheme selector -! jx - integer(optional). The starting column of the global matrix. -! ik - integer(optional). The number of columns to gather. -! work - real(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer(optional). Which index list in desc_a should be used. -! -subroutine psb_dhalom_new(x,desc_a,info,comm_type,jx,ik,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_dhalom_new - use psi_mod - implicit none - - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: comm_type - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, k - integer(psb_ipk_) :: err_act, iix, jjx, maxk, nrow, imode, i,& - & liwork, data_, ldx - integer(psb_lpk_) :: m, n, ix, ijx - real(psb_dpk_), pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dhalom_new' - 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() - - ! check on blacs grid - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - - ! - ! Select the communication mode based on comm_type - ! - select case(comm_type) - case(0) - ! - ! Classic irecv/send scheme (default) - ! - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - case(1) - if(present(mode)) then - imode = mode - else - imode = IOR(psb_swap_start_,psb_swap_wait_) - endif - - case default - info = psb_err_input_value_invalid_i_ - call psb_errpush(info,name,i_err=(/5_psb_ipk_,comm_type,izero,izero,izero/)) - goto 9999 - end select - - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - xp => x(iix:size(x,1),jjx:jjx+k-1) - if(tran_ == 'N') then - call psi_swapdata(imode,k,dzero,xp,& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,k,done,xp,& - &desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ctxt,err_act) - - return -end subroutine psb_dhalom_new - - -! -! Subroutine: psb_dhalov_new -! This subroutine performs the exchange of the halo elements in a -! distributed dense vector between all the processes. -! The comm_type argument selects the communication scheme: -! psb_comm_type_isend_ (0) = classic irecv/send (default) -! psb_comm_type_neigh_a2av_ (1) = MPI_Alltoallv collective -! -! Arguments: -! x - real,dimension(:). The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! comm_type - integer. Communication scheme selector -! work - real(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer(optional). Which index list in desc_a should be used. -! -subroutine psb_dhalov_new(x,desc_a,info,comm_type,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_dhalov_new - use psi_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: comm_type - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork, data_ - integer(psb_lpk_) :: m, n, ix, ijx - real(psb_dpk_), pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dhalov_new' - 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() - - ! check on blacs grid - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - - ! - ! Select the communication mode based on comm_type - ! - select case(comm_type) - case(0) - ! - ! Classic irecv/send scheme (default) - ! - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - case(1) - if(present(mode)) then - imode = mode - else - imode = IOR(psb_swap_start_,psb_swap_wait_) - endif - - case default - info = psb_err_input_value_invalid_i_ - call psb_errpush(info,name,i_err=(/4_psb_ipk_,comm_type,izero,izero,izero/)) - goto 9999 - end select - - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - if(tran_ == 'N') then - call psi_swapdata(imode,dzero,x(iix:size(x)),& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,done,x(iix:size(x)),& - & desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ctxt,err_act) - - return -end subroutine psb_dhalov_new diff --git a/base/comm/psb_dhalo_new.F90 b/base/comm/psb_dhalo_new.F90 deleted file mode 100644 index 785ecaaa..00000000 --- a/base/comm/psb_dhalo_new.F90 +++ /dev/null @@ -1,298 +0,0 @@ -! -! 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 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. -! -! -! File: psb_dhalo_new.f90 -! -! Subroutine: psb_dhalo_vect_new -! Halo exchange for a distributed vector. -! comm_type selects the communication scheme: -! psb_comm_type_isend_ (0) : classic isend/irecv (delegates to psi_swapdata) -! psb_comm_type_neigh_a2av_ (1) : MPI_Neighbor_alltoallv via pre-built topology -! -subroutine psb_dhalo_vect_new(x,desc_a,info,comm_type,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_dhalo_vect_new - use psi_mod - 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) :: comm_type - real(psb_dpk_), target, optional, intent(inout) :: work(:) - 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, & - & nrow, ncol, lldx, imode, liwork, data_ - real(psb_dpk_),pointer :: iwork(:) - real(psb_dpk_), allocatable :: sndbuf(:), rcvbuf(:) - character :: tran_ - character(len=40) :: name, ch_err - logical :: aliw - integer(psb_mpk_) :: iret - integer(psb_ipk_) :: k - - name='psb_dhalo_vect_new' - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - - ctxt=desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - lldx = x%get_nrows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - - if ((info == 0).and.(lldx < ncol)) call x%reall(ncol,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ ; ch_err='reall' - call psb_errpush(info,name,a_err=ch_err); goto 9999 - end if - - select case(comm_type) - case(0) ! psb_comm_type_isend_ - ! ---- Classic isend/irecv: delegate to psi_swapdata ---- - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - end if - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - iwork => work; aliw=.false. - else - aliw=.true.; allocate(iwork(liwork),stat=info) - end if - else - aliw=.true.; allocate(iwork(liwork),stat=info) - end if - if(info /= psb_success_) then - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if(tran_ == 'N') then - call psi_swapdata(imode,dzero,x%v,desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,done,x%v,desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran'); goto 9999 - end if - - if (info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - if (aliw) deallocate(iwork) - nullify(iwork) - - case(1) ! psb_comm_type_neigh_a2av_ - ! TODO - case default - info = psb_err_input_value_invalid_i_ - call psb_errpush(info,name,i_err=(/5_psb_ipk_,comm_type,izero,izero,izero/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psb_dhalo_vect_new - - -! -! Subroutine: psb_dhalo_multivect_new -! Halo exchange for a distributed multivector. -! comm_type selects the communication scheme: -! psb_comm_type_isend_ (0) : classic isend/irecv -! psb_comm_type_neigh_a2av_ (1) : MPI_Neighbor_alltoallv via pre-built topology -! -subroutine psb_dhalo_multivect_new(x,desc_a,info,comm_type,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_dhalo_multivect_new - 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) :: comm_type - real(psb_dpk_), target, optional, intent(inout) :: work(:) - 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, & - & nrow, ncol, lldx, imode, liwork, data_, nc - real(psb_dpk_),pointer :: iwork(:) - real(psb_dpk_), allocatable :: sndbuf(:), rcvbuf(:) - integer(psb_mpk_), allocatable :: mv_sndcnts(:), mv_rcvcnts(:), & - & mv_snddispls(:), mv_rcvdispls(:) - character :: tran_ - character(len=40) :: name, ch_err - logical :: aliw - integer(psb_mpk_) :: iret - integer(psb_ipk_) :: k, j, bp, nn - - name='psb_dhalo_multivect_new' - info=psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - - ctxt=desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name); goto 9999 - endif - - if (.not.allocated(x%v)) then - info = psb_err_invalid_vect_state_ - call psb_errpush(info,name); goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - lldx = x%get_nrows() - nc = x%get_ncols() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - - if (lldx < ncol) call x%reall(ncol,nc,info) - if(info /= psb_success_) then - ch_err='psb_reall' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - select case(comm_type) - case(0) - ! ---- Classic isend/irecv ---- - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - end if - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - iwork => work; aliw=.false. - else - aliw=.true.; allocate(iwork(liwork),stat=info) - end if - else - aliw=.true.; allocate(iwork(liwork),stat=info) - end if - if(info /= psb_success_) then - ch_err='psb_realloc' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if(tran_ == 'N') then - call psi_swapdata(imode,dzero,x%v,desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,done,x%v,desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran'); goto 9999 - end if - - if (info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - if (aliw) deallocate(iwork) - nullify(iwork) - - case(1) - ! TODO - - case default - info = psb_err_input_value_invalid_i_ - call psb_errpush(info,name,i_err=(/5_psb_ipk_,comm_type,izero,izero,izero/)) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psb_dhalo_multivect_new diff --git a/base/modules/comm/psb_c_comm_a_mod.f90 b/base/modules/comm/psb_c_comm_a_mod.f90 index b374e6a9..9e8f72ce 100644 --- a/base/modules/comm/psb_c_comm_a_mod.f90 +++ b/base/modules/comm/psb_c_comm_a_mod.f90 @@ -76,32 +76,6 @@ module psb_c_comm_a_mod end subroutine psb_chalov end interface psb_halo - interface psb_halo_new - subroutine psb_chalom_new(x,desc_a,info,comm_type,jx,ik,work,tran,mode,data) - import - implicit none - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: comm_type - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_chalom_new - subroutine psb_chalov_new(x,desc_a,info,comm_type,work,tran,mode,data) - import - implicit none - complex(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: comm_type - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_chalov_new - end interface psb_halo_new - - interface psb_scatter subroutine psb_cscatterm(globx, locx, desc_a, info, root) import diff --git a/base/modules/comm/psb_c_comm_mod.f90 b/base/modules/comm/psb_c_comm_mod.f90 index c2d5723d..1bd46197 100644 --- a/base/modules/comm/psb_c_comm_mod.f90 +++ b/base/modules/comm/psb_c_comm_mod.f90 @@ -57,31 +57,6 @@ module psb_c_comm_mod end subroutine psb_covrl_multivect end interface psb_ovrl - interface psb_halo_new - subroutine psb_chalo_vect_new(x,desc_a,info,comm_type,work,tran,mode,data) - import - 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) :: comm_type - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_chalo_vect_new - subroutine psb_chalo_multivect_new(x,desc_a,info,comm_type,work,tran,mode,data) - 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) :: comm_type - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_chalo_multivect_new - end interface psb_halo_new - interface psb_halo subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) import diff --git a/base/modules/comm/psb_d_comm_a_mod.f90 b/base/modules/comm/psb_d_comm_a_mod.f90 index 3e3515bc..9e5edc24 100644 --- a/base/modules/comm/psb_d_comm_a_mod.f90 +++ b/base/modules/comm/psb_d_comm_a_mod.f90 @@ -53,51 +53,26 @@ module psb_d_comm_a_mod end subroutine psb_dovrlv end interface psb_ovrl - interface psb_halo_new - subroutine psb_dhalom_new(x,desc_a,info,comm_type,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 - integer(psb_ipk_), intent(in) :: comm_type - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_dhalom_new - subroutine psb_dhalov_new(x,desc_a,info,comm_type,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 - integer(psb_ipk_), intent(in) :: comm_type - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_dhalov_new - end interface psb_halo_new - interface psb_halo 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 f9b8a809..528a066a 100644 --- a/base/modules/comm/psb_d_comm_mod.f90 +++ b/base/modules/comm/psb_d_comm_mod.f90 @@ -57,52 +57,26 @@ module psb_d_comm_mod end subroutine psb_dovrl_multivect end interface psb_ovrl - - interface psb_halo_new - subroutine psb_dhalo_vect_new(x,desc_a,info,comm_type,work,tran,mode,data) + interface psb_halo + subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) 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) :: comm_type real(psb_dpk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran - end subroutine psb_dhalo_vect_new - subroutine psb_dhalo_multivect_new(x,desc_a,info,comm_type,work,tran,mode,data) + end subroutine psb_dhalo_vect + subroutine psb_dhalo_multivect(x,desc_a,info,work,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 - integer(psb_ipk_), intent(in) :: comm_type real(psb_dpk_), target, optional, intent(inout) :: work(:) integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran - end subroutine psb_dhalo_multivect_new - end interface psb_halo_new - - interface psb_halo - subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) - 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 - real(psb_dpk_), target, optional, intent(inout) :: work(:) - 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,work,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 - real(psb_dpk_), target, optional, intent(inout) :: work(:) - 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_s_comm_a_mod.f90 b/base/modules/comm/psb_s_comm_a_mod.f90 index 7d67c7ca..fa8deb09 100644 --- a/base/modules/comm/psb_s_comm_a_mod.f90 +++ b/base/modules/comm/psb_s_comm_a_mod.f90 @@ -76,32 +76,6 @@ module psb_s_comm_a_mod end subroutine psb_shalov end interface psb_halo - interface psb_halo_new - subroutine psb_shalom_new(x,desc_a,info,comm_type,jx,ik,work,tran,mode,data) - import - implicit none - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: comm_type - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_shalom_new - subroutine psb_shalov_new(x,desc_a,info,comm_type,work,tran,mode,data) - import - implicit none - real(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: comm_type - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_shalov_new - end interface psb_halo_new - - interface psb_scatter subroutine psb_sscatterm(globx, locx, desc_a, info, root) import diff --git a/base/modules/comm/psb_s_comm_mod.f90 b/base/modules/comm/psb_s_comm_mod.f90 index 7c333f84..a202b5b6 100644 --- a/base/modules/comm/psb_s_comm_mod.f90 +++ b/base/modules/comm/psb_s_comm_mod.f90 @@ -57,31 +57,6 @@ module psb_s_comm_mod end subroutine psb_sovrl_multivect end interface psb_ovrl - interface psb_halo_new - subroutine psb_shalo_vect_new(x,desc_a,info,comm_type,work,tran,mode,data) - import - 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) :: comm_type - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_shalo_vect_new - subroutine psb_shalo_multivect_new(x,desc_a,info,comm_type,work,tran,mode,data) - 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) :: comm_type - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_shalo_multivect_new - end interface psb_halo_new - interface psb_halo subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) import diff --git a/base/modules/comm/psb_z_comm_mod.f90 b/base/modules/comm/psb_z_comm_mod.f90 index 4c9ca091..304cdfb9 100644 --- a/base/modules/comm/psb_z_comm_mod.f90 +++ b/base/modules/comm/psb_z_comm_mod.f90 @@ -57,31 +57,6 @@ module psb_z_comm_mod end subroutine psb_zovrl_multivect end interface psb_ovrl - interface psb_halo_new - subroutine psb_zhalo_vect_new(x,desc_a,info,comm_type,work,tran,mode,data) - import - 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) :: comm_type - complex(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_zhalo_vect_new - subroutine psb_zhalo_multivect_new(x,desc_a,info,comm_type,work,tran,mode,data) - 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) :: comm_type - complex(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_zhalo_multivect_new - end interface psb_halo_new - interface psb_halo subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) import diff --git a/base/modules/comm/psi_d_comm_a_mod.f90 b/base/modules/comm/psi_d_comm_a_mod.f90 index b1dda3f8..1521e855 100644 --- a/base/modules/comm/psi_d_comm_a_mod.f90 +++ b/base/modules/comm/psi_d_comm_a_mod.f90 @@ -34,26 +34,38 @@ module psi_d_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type interface psi_swapdata + ! ---------------------------------------------------------------------------------- + ! Upper level routine to swap data between two ASB descriptors. The swap is performed + ! according to the flag argument + ! ---------------------------------------------------------------------------------- subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) import integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatam subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatav - subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + ! ---------------------------------------------------------------------------------- + + ! ---------------------------------------------------------------------------------- + ! Lower level routine to swap data between two ASB descriptors. The swap is performed + ! according to the flag argument. The swap is performed on a subset of the data, + ! according to the idx array. The swap is performed on the data of the local process + ! only. The swap is performed according to the flag argument + ! ---------------------------------------------------------------------------------- + subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import type(psb_ctxt_type), intent(in) :: ctxt @@ -61,9 +73,9 @@ module psi_d_comm_a_mod integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxm subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) @@ -72,10 +84,11 @@ module psi_d_comm_a_mod integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxv + ! ---------------------------------------------------------------------------------- end interface psi_swapdata diff --git a/base/modules/comm/psi_d_comm_v_mod.f90 b/base/modules/comm/psi_d_comm_v_mod.f90 index 418b0789..be405a09 100644 --- a/base/modules/comm/psi_d_comm_v_mod.f90 +++ b/base/modules/comm/psi_d_comm_v_mod.f90 @@ -126,6 +126,9 @@ module psi_d_comm_v_mod end interface psi_dswap_neighbor_topology_vect interface psi_swaptran + ! --------------------------------------------------------------- + ! Upper call in order to populate idx using desc_a%get_list_p + ! --------------------------------------------------------------- subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -146,6 +149,12 @@ module psi_d_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_multivect + ! --------------------------------------------------------------- + + ! --------------------------------------------------------------- + ! Wrapper that calls different communications schemes depending on + ! flag variable + ! --------------------------------------------------------------- subroutine psi_dtran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -172,6 +181,8 @@ module psi_d_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dtran_vidx_multivect + ! --------------------------------------------------------------- + end interface psi_swaptran interface psi_ovrl_upd diff --git a/base/modules/desc/psb_desc_mod.F90 b/base/modules/desc/psb_desc_mod.F90 index b83542a4..2fbdf47f 100644 --- a/base/modules/desc/psb_desc_mod.F90 +++ b/base/modules/desc/psb_desc_mod.F90 @@ -199,23 +199,25 @@ module psb_desc_mod type psb_desc_type - class(psb_indx_map), allocatable :: indxmap - - integer(psb_ipk_), allocatable :: halo_index(:) - integer(psb_ipk_), allocatable :: ext_index(:) - integer(psb_ipk_), allocatable :: ovrlap_index(:) - integer(psb_ipk_), allocatable :: ovr_mst_idx(:) - - type(psb_i_vect_type) :: v_halo_index - type(psb_i_vect_type) :: v_ext_index - type(psb_i_vect_type) :: v_ovrlap_index - type(psb_i_vect_type) :: v_ovr_mst_idx - - integer(psb_ipk_), allocatable :: ovrlap_elem(:,:) - integer(psb_ipk_), allocatable :: bnd_elem(:) - integer(psb_ipk_), allocatable :: lprm(:) - type(psb_desc_type), pointer :: base_desc => null() - integer(psb_ipk_), allocatable :: idx_space(:) + class(psb_indx_map), allocatable :: indxmap + + integer(psb_ipk_), allocatable :: halo_index(:) + integer(psb_ipk_), allocatable :: ext_index(:) + integer(psb_ipk_), allocatable :: ovrlap_index(:) + integer(psb_ipk_), allocatable :: ovr_mst_idx(:) + + type(psb_i_vect_type) :: v_halo_index + type(psb_i_vect_type) :: v_ext_index + type(psb_i_vect_type) :: v_ovrlap_index + type(psb_i_vect_type) :: v_ovr_mst_idx + + integer(psb_ipk_), allocatable :: ovrlap_elem(:,:) + integer(psb_ipk_), allocatable :: bnd_elem(:) + integer(psb_ipk_), allocatable :: lprm(:) + type(psb_desc_type), pointer :: base_desc => null() + integer(psb_ipk_), allocatable :: idx_space(:) + + integer(psb_ipk_) :: communication_mode contains procedure, pass(desc) :: is_ok => psb_is_ok_desc procedure, pass(desc) :: is_valid => psb_is_valid_desc @@ -270,7 +272,8 @@ module psb_desc_mod generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins - + procedure, pass(desc) :: get_communication_mode => psb_get_communication_mode + procedure, pass(desc) :: set_communication_mode => psb_set_communication_mode end type psb_desc_type @@ -1902,4 +1905,64 @@ contains end subroutine cd_fnd_owner + function psb_get_communication_mode(desc) result(mode) + use psb_error_mod + + implicit none + + integer(psb_ipk_) :: mode + class(psb_desc_type), intent(in) :: desc + integer(psb_ipk_) :: err_act, info + + info = psb_success_ + mode = desc%communication_mode + if( ( iand(mode,psb_swap_send_) /= 0 ) & + & .or. ( iand(mode,psb_swap_recv_) /= 0 ) & + & .or. ( iand(mode,psb_swap_sync_) /= 0 ) & + & .or. ( iand(mode,psb_swap_mpi_) /= 0 ) & + & .or. ( iand(mode,psb_swap_start_) /= 0 ) & + & .or. ( iand(mode, psb_swap_wait_) /= 0 ) ) then + info = psb_err_incoherent_comm_state_ + call psb_errpush(info,'psb_get_communication_mode',a_err='invalid comm mode') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + end function psb_get_communication_mode + + subroutine psb_set_communication_mode(desc, mode) + use psb_error_mod + + implicit none + class(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(in) :: mode + integer(psb_ipk_) :: err_act, info + + info = psb_success_ + if( ( iand(mode,psb_swap_send_) /= 0 ) & + & .or. ( iand(mode,psb_swap_recv_) /= 0 ) & + & .or. ( iand(mode,psb_swap_sync_) /= 0 ) & + & .or. ( iand(mode,psb_swap_mpi_) /= 0 ) & + & .or. ( iand(mode,psb_swap_start_) /= 0 ) & + & .or. ( iand(mode, psb_swap_wait_) /= 0 ) ) then + info = psb_err_incoherent_comm_state_ + call psb_errpush(info,'psb_set_communication_mode',a_err='invalid comm mode') + goto 9999 + end if + + desc%communication_mode = mode + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine psb_set_communication_mode + + end module psb_desc_mod diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 34b08343..2389ba5e 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -326,13 +326,14 @@ module psb_const_mod integer(psb_ipk_), parameter, public :: psb_err_invalid_irst_ =5002 integer(psb_ipk_), parameter, public :: psb_err_invalid_preci_=5003 integer(psb_ipk_), parameter, public :: psb_err_invalid_preca_=5004 - integer(psb_ipk_), parameter, public :: psb_err_topology_error_=6000 - integer(psb_ipk_), parameter, public :: psb_err_topology_invalid_args_=6001 - integer(psb_ipk_), parameter, public :: psb_err_topology_args_mismatch_=6002 + integer(psb_ipk_), parameter, public :: psb_err_incoherent_comm_state_ = 6000 ! Used when communication type bitmask has more then one bit flipped + integer(psb_ipk_), parameter, public :: psb_err_topology_error_ = 7000 + integer(psb_ipk_), parameter, public :: psb_err_topology_invalid_args_ = 7001 + integer(psb_ipk_), parameter, public :: psb_err_topology_args_mismatch_ = 7002 type :: psb_ctxt_type - integer(psb_mpk_), allocatable :: ctxt + integer(psb_mpk_), allocatable :: ctxt contains procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt end type psb_ctxt_type diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index b671943d..71bcc13e 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -2681,6 +2681,9 @@ 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(:) + + integer(psb_mpk_) :: communication_handle + type(psb_neighbor_topology_type) :: neighbor_topology contains ! ! Constructors/allocators @@ -2806,6 +2809,11 @@ 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 + + ! Neighbor alltoallv communication topology handling + procedure, pass(x) :: init_topology => d_base_mlv_init_topology + procedure, pass(x) :: free_topology => d_base_mlv_free_topology + end type psb_d_base_multivect_type interface psb_d_base_multivect @@ -4329,4 +4337,32 @@ contains end subroutine d_base_mlv_device_wait + ! -------------------------------------------------------------------- + ! Implementation of methods used for neighbor alltoallv communication + ! -------------------------------------------------------------------- + subroutine d_base_mlv_init_topology(x, halo_index, num_exchanges, & + & total_send_elems, total_recv_elems, ctxt, icomm, info) + implicit none + class(psb_d_base_multivect_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 d_base_mlv_init_topology + + subroutine d_base_mlv_free_topology(x, info) + implicit none + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + call x%neighbor_topology%free(info) + + end subroutine d_base_mlv_free_topology + ! -------------------------------------------------------------------- + end module psb_d_base_multivect_mod diff --git a/cbind/psb_c_base.h b/cbind/psb_c_base.h deleted file mode 100644 index e1e18670..00000000 --- a/cbind/psb_c_base.h +++ /dev/null @@ -1,149 +0,0 @@ -#ifndef PSB_C_BASE__ -#define PSB_C_BASE__ -#ifdef __cplusplus -extern "C" { - /*typedef char _Bool;*/ -#endif - -#include -#ifdef __cplusplus -#include -#else -#include -#endif -#include -#include -#include -#include -#include - -#include "psb_config.h" -#include "psb_types.h" - - - typedef struct PSB_C_DESCRIPTOR { - void *descriptor; - } psb_c_descriptor; - - - typedef struct PSB_C_CTXT { - psb_i_t *ctxt; - } psb_c_ctxt; - - - - void psb_c_check_error(psb_c_ctxt cctxt); - psb_i_t psb_c_error(); - psb_i_t psb_c_clean_errstack(); - void psb_c_print_errmsg(); - char *psb_c_pop_errmsg(); - psb_i_t psb_c_f2c_errmsg(char *, psb_i_t); - void psb_c_seterraction_ret(); - void psb_c_seterraction_print(); - void psb_c_seterraction_abort(); - - /* Environment routines */ - void psb_c_init(psb_c_ctxt *cctxt); - void psb_c_init_from_fint(psb_c_ctxt *cctxt, psb_i_t f_comm); - void psb_c_exit(psb_c_ctxt cctxt); - void psb_c_exit_ctxt(psb_c_ctxt cctxt); - void psb_c_abort(psb_c_ctxt cctxt); - void psb_c_barrier(psb_c_ctxt cctxt); - void psb_c_info(psb_c_ctxt cctxt, psb_i_t *iam, psb_i_t *np); - void psb_c_get_i_ctxt(psb_c_ctxt cctxt, psb_i_t *ictxt, psb_i_t *info); - bool psb_c_cmp_ctxt(psb_c_ctxt cctxt1, psb_c_ctxt cctxt2); - psb_d_t psb_c_wtime(); - psb_i_t psb_c_get_errstatus(); - - psb_i_t psb_c_get_index_base(); - void psb_c_set_index_base(psb_i_t base); - /* GPU environment routines */ - #ifdef PSB_HAVE_CUDA - void psb_c_cuda_init(psb_c_ctxt *cctxt); - void psb_c_cuda_init_opt(psb_c_ctxt *cctxt, psb_m_t ngpu); - void psb_c_cuda_exit(); - psb_m_t psb_c_cuda_getDeviceCount(); - #endif - - void psb_c_mbcast(psb_c_ctxt cctxt, psb_i_t n, psb_m_t *v, psb_i_t root); - void psb_c_ibcast(psb_c_ctxt cctxt, psb_i_t n, psb_i_t *v, psb_i_t root); - void psb_c_lbcast(psb_c_ctxt cctxt, psb_i_t n, psb_l_t *v, psb_i_t root); - void psb_c_ebcast(psb_c_ctxt cctxt, psb_i_t n, psb_e_t *v, psb_i_t root); - void psb_c_sbcast(psb_c_ctxt cctxt, psb_i_t n, psb_s_t *v, psb_i_t root); - void psb_c_dbcast(psb_c_ctxt cctxt, psb_i_t n, psb_d_t *v, psb_i_t root); - void psb_c_cbcast(psb_c_ctxt cctxt, psb_i_t n, psb_c_t *v, psb_i_t root); - void psb_c_zbcast(psb_c_ctxt cctxt, psb_i_t n, psb_z_t *v, psb_i_t root); - void psb_c_hbcast(psb_c_ctxt cctxt, const char *v, psb_i_t root); - - /* Descriptor/integer routines */ - psb_c_descriptor* psb_c_new_descriptor(); - void psb_c_delete_descriptor(psb_c_descriptor *); - psb_c_ctxt* psb_c_new_ctxt(); - void psb_c_delete_ctxt(psb_c_ctxt *); - psb_i_t psb_c_cdall_vg(psb_l_t ng, psb_i_t *vg, psb_c_ctxt cctxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_vl(psb_i_t nl, psb_l_t *vl, psb_c_ctxt cctxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_vl_lidx(psb_i_t nl, psb_l_t *vl, psb_i_t *lidx, psb_c_ctxt cctxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_nl(psb_i_t nl, psb_c_ctxt cctxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_repl(psb_l_t n, psb_c_ctxt cctxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdasb(psb_c_descriptor *cd); - psb_i_t psb_c_cdasb_format(psb_c_descriptor *cd, const char *afmt); - psb_i_t psb_c_cdfree(psb_c_descriptor *cd); - psb_i_t psb_c_cdins(psb_i_t nz, const psb_l_t *ia, const psb_l_t *ja, psb_c_descriptor *cd); - psb_i_t psb_c_cdins_lidx(psb_i_t nz, const psb_l_t *ja, const psb_i_t *lidx, psb_c_descriptor *cd); - bool psb_c_is_owned(psb_l_t gindex, psb_c_descriptor *cd); - bool psb_c_cd_is_asb(psb_c_descriptor *cd); - psb_i_t psb_c_cd_check_addr(psb_c_descriptor *cd); - - - psb_i_t psb_c_cd_get_local_rows(psb_c_descriptor *cd); - psb_i_t psb_c_cd_get_local_cols(psb_c_descriptor *cd); - psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); - psb_l_t psb_c_cd_get_global_cols(psb_c_descriptor *cd); - psb_i_t psb_c_cd_get_global_indices(psb_l_t idx[], psb_i_t nidx, bool owned, psb_c_descriptor *cd); - psb_i_t psb_c_g2l(psb_c_descriptor *cdh,psb_l_t gindex,bool cowned); - - - - /* legal values for afmt */ -#define PSB_AFMT_CSR "CSR" -#define PSB_AFMT_CSC "CSC" -#define PSB_AFMT_COO "COO" -#define PSB_AFMT_RSB "RSB" - - /* Transpose argument */ -#define psb_NoTrans_ "N" -#define psb_Trans_ "T" -#define psb_ConjTrans_ "C" - -#if 0 - /* legal values for upd argument */ -#define psb_upd_srch_ 98764 -#define psb_upd_perm_ 98765 -#define psb_upd_def_ psb_upd_srch_ - /* legal values for dupl argument */ -#define psb_dupl_ovwrt_ 0 -#define psb_dupl_add_ 1 -#define psb_dupl_err_ 2 -#define psb_dupl_def_ psb_dupl_ovwrt_ - - /* legal values for halo swap modes argument */ -#define psb_swap_send_ 1 -#define psb_swap_recv_ 2 -#define psb_swap_sync_ 4 -#define psb_swap_mpi_ 8 -#define psb_swap_start_ 16 -#define psb_swap_wait_ 32 - - /* legal values for ovrl update argument */ -#define psb_none_ 0 -#define psb_sum_ 1 -#define psb_avg_ 2 -#define psb_square_root_ 3 -#define psb_setzero_ 4 -#endif - -#ifdef __cplusplus -} -#endif /* __cplusplus */ - -#endif diff --git a/cbind/psb_c_cbase.h b/cbind/psb_c_cbase.h deleted file mode 100644 index dcf37965..00000000 --- a/cbind/psb_c_cbase.h +++ /dev/null @@ -1,109 +0,0 @@ -#ifndef PSB_C_CBASE_ -#define PSB_C_CBASE_ -#include "psb_c_base.h" - -#ifdef __cplusplus -extern "C" { -#endif - -typedef struct PSB_C_CVECTOR { - void *cvector; -} psb_c_cvector; - -typedef struct PSB_C_CSPMAT { - void *cspmat; -} psb_c_cspmat; - - -/* dense vectors */ -psb_c_cvector* psb_c_new_cvector(); -psb_i_t psb_c_cvect_get_nrows(psb_c_cvector *xh); -psb_c_t *psb_c_cvect_get_cpy( psb_c_cvector *xh); -psb_i_t psb_c_cvect_f_get_cpy(psb_c_t *v, psb_c_cvector *xh); -psb_i_t psb_c_cvect_zero(psb_c_cvector *xh); -psb_i_t *psb_c_cvect_f_get_pnt(psb_c_cvector *xh); -psb_i_t psb_c_cvect_clone(psb_c_cvector *xh,psb_c_cvector *yh); - -psb_i_t psb_c_cgeall(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeall_remote(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeall_remote_options(psb_c_cvector *xh, psb_c_descriptor *cdh, - psb_i_t bldmode, psb_i_t duple); -psb_i_t psb_c_cgeins(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val, - psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val, - psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeasb(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeasb_options(psb_c_cvector *xh, psb_c_descriptor *cdh, psb_i_t dupl); -psb_i_t psb_c_cgeasb_options_format(psb_c_cvector *xh, psb_c_descriptor *cdh, - const char *fmt, psb_i_t dupl); -psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd); - -/* sparse matrices*/ -psb_c_cspmat* psb_c_new_cspmat(); -psb_i_t psb_c_cspall(psb_c_cspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspall_remote(psb_c_cspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspasb(psb_c_cspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspfree(psb_c_cspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, - const psb_c_t *val, psb_c_cspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_cmat_get_nrows(psb_c_cspmat *mh); -psb_i_t psb_c_cmat_get_ncols(psb_c_cspmat *mh); -psb_l_t psb_c_cnnz(psb_c_cspmat *mh,psb_c_descriptor *cdh); -bool psb_c_cis_matupd(psb_c_cspmat *mh,psb_c_descriptor *cdh); -bool psb_c_cis_matasb(psb_c_cspmat *mh,psb_c_descriptor *cdh); -bool psb_c_cis_matbld(psb_c_cspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_cset_matupd(psb_c_cspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_cset_matasb(psb_c_cspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_cset_matbld(psb_c_cspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_ccopy_mat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_c_descriptor *cdh); - -psb_i_t psb_c_cspasb_opt(psb_c_cspmat *mh, psb_c_descriptor *cdh, - const char *afmt, psb_i_t upd, psb_i_t dupl); -psb_i_t psb_c_csprn(psb_c_cspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name); -psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val); -psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n); - -/* psblas computational routines */ -psb_c_t psb_c_cgedot(psb_c_cvector *xh, psb_c_cvector *yh, psb_c_descriptor *cdh); -psb_s_t psb_c_cgenrm2(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_cgeamax(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_cgeasum(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_cgenrmi(psb_c_cspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeaxpby(psb_c_t alpha, psb_c_cvector *xh, - psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeaxpbyz(psb_c_t alpha, psb_c_cvector *xh, - psb_c_t beta, psb_c_cvector *yh, psb_c_cvector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspmm(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh, - psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspmm_opt(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh, - psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh, - char *trans, bool doswap); -psb_i_t psb_c_cspsm(psb_c_t alpha, psb_c_cspmat *th, psb_c_cvector *xh, - psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); -/* Additional computational routines */ -psb_i_t psb_c_cgemlt(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_cgemlt2(psb_c_t alpha, psb_c_cvector *xh, psb_c_cvector *yh, psb_c_t beta, psb_c_cvector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgediv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_cgediv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_cgediv2(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *zh,psb_c_descriptor *cdh); -psb_i_t psb_c_cgediv2_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *zh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_cgeinv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_cgeinv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_cgeabs(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *cdh); -psb_i_t psb_c_cgecmp(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh); -bool psb_c_cgecmpmat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_s_t tol,psb_c_descriptor *cdh); -bool psb_c_cgecmpmat_val(psb_c_cspmat *ah,psb_c_t val,psb_s_t tol,psb_c_descriptor *cdh); -psb_i_t psb_c_cgeaddconst(psb_c_cvector *xh,psb_c_t bh,psb_c_cvector *zh,psb_c_descriptor *cdh); -psb_s_t psb_c_cgenrm2_weight(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_descriptor *cdh); -psb_s_t psb_c_cgenrm2_weightmask(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_cvector *idvh,psb_c_descriptor *cdh); -psb_i_t psb_c_cspscal(psb_c_t alpha, psb_c_cspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_cspscalpid(psb_c_t alpha, psb_c_cspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_cspaxpby(psb_c_t alpha, psb_c_cspmat *ah, psb_c_t beta, psb_c_cspmat *bh, psb_c_descriptor *cdh); - -#ifdef __cplusplus -} -#endif /* __cplusplus */ - -#endif diff --git a/cbind/psb_c_dbase.h b/cbind/psb_c_dbase.h deleted file mode 100644 index 6a82fe77..00000000 --- a/cbind/psb_c_dbase.h +++ /dev/null @@ -1,113 +0,0 @@ -#ifndef PSB_C_DBASE_ -#define PSB_C_DBASE_ -#include "psb_c_base.h" - -#ifdef __cplusplus -extern "C" { -#endif - -typedef struct PSB_C_DVECTOR { - void *dvector; -} psb_c_dvector; - -typedef struct PSB_C_DSPMAT { - void *dspmat; -} psb_c_dspmat; - - -/* dense vectors */ -psb_c_dvector* psb_c_new_dvector(); -psb_i_t psb_c_dvect_get_nrows(psb_c_dvector *xh); -psb_d_t *psb_c_dvect_get_cpy( psb_c_dvector *xh); -psb_i_t psb_c_dvect_f_get_cpy(psb_d_t *v, psb_c_dvector *xh); -psb_i_t psb_c_dvect_zero(psb_c_dvector *xh); -psb_d_t *psb_c_dvect_f_get_pnt( psb_c_dvector *xh); -psb_i_t psb_c_dvect_clone(psb_c_dvector *xh,psb_c_dvector *yh); - -psb_i_t psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeall_remote(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeall_remote_options(psb_c_dvector *xh, psb_c_descriptor *cdh, - psb_i_t bldmode, psb_i_t duple); -psb_i_t psb_c_dgeins(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, - psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, - psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeasb_options(psb_c_dvector *xh, psb_c_descriptor *cdh, psb_i_t dupl); -psb_i_t psb_c_dgeasb_options_format(psb_c_dvector *xh, psb_c_descriptor *cdh, - psb_i_t dupl, const char *fmt); -psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd); - -/* sparse matrices*/ -psb_c_dspmat* psb_c_new_dspmat(); -psb_i_t psb_c_dspall(psb_c_dspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspall_remote(psb_c_dspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspasb(psb_c_dspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspfree(psb_c_dspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, - const psb_d_t *val, psb_c_dspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_dmat_get_nrows(psb_c_dspmat *mh); -psb_i_t psb_c_dmat_get_ncols(psb_c_dspmat *mh); -psb_l_t psb_c_dnnz(psb_c_dspmat *mh,psb_c_descriptor *cdh); -bool psb_c_dis_matupd(psb_c_dspmat *mh,psb_c_descriptor *cdh); -bool psb_c_dis_matasb(psb_c_dspmat *mh,psb_c_descriptor *cdh); -bool psb_c_dis_matbld(psb_c_dspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_dset_matupd(psb_c_dspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_dset_matasb(psb_c_dspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_dset_matbld(psb_c_dspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_dcopy_mat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_c_descriptor *cdh); - -psb_i_t psb_c_dspasb_opt(psb_c_dspmat *mh, psb_c_descriptor *cdh, - const char *afmt, psb_i_t upd, psb_i_t dupl); -psb_i_t psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name); -psb_i_t psb_c_dvect_set_scal(psb_c_dvector *xh, psb_d_t val); -psb_i_t psb_c_dvect_set_vect(psb_c_dvector *xh, psb_d_t *val, psb_i_t n); - -/* psblas computational routines */ -psb_d_t psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh); -psb_d_t psb_c_dgenrm2(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_dgeamax(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_dgeasum(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_dgenrmi(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeaxpby(psb_d_t alpha, psb_c_dvector *xh, - psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeaxpbyz(psb_d_t alpha, psb_c_dvector *xh, - psb_d_t beta, psb_c_dvector *yh, psb_c_dvector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspmm(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh, - psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspmm_opt(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh, - psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh, - char *trans, bool doswap); -psb_i_t psb_c_dspsm(psb_d_t alpha, psb_c_dspmat *th, psb_c_dvector *xh, - psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); -/* Additional computational routines */ -psb_i_t psb_c_dgemlt(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_dgemlt2(psb_d_t alpha, psb_c_dvector *xh, psb_c_dvector *yh, psb_d_t beta, psb_c_dvector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgediv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_dgediv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_dgediv2(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_dvector *zh,psb_c_descriptor *cdh); -psb_i_t psb_c_dgediv2_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_dvector *zh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_dgeinv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_dgeinv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_dgeabs(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_dgecmp(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh); -bool psb_c_dgecmpmat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_d_t tol,psb_c_descriptor *cdh); -bool psb_c_dgecmpmat_val(psb_c_dspmat *ah,psb_d_t val,psb_d_t tol,psb_c_descriptor *cdh); -psb_i_t psb_c_dgeaddconst(psb_c_dvector *xh,psb_d_t bh,psb_c_dvector *zh,psb_c_descriptor *cdh); -psb_d_t psb_c_dgenrm2_weight(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_descriptor *cdh); -psb_d_t psb_c_dgenrm2_weightmask(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_dvector *idvh,psb_c_descriptor *cdh); -psb_i_t psb_c_dmask(psb_c_dvector *ch,psb_c_dvector *xh,psb_c_dvector *mh, bool *t, psb_c_descriptor *cdh); -psb_d_t psb_c_dgemin(psb_c_dvector *xh,psb_c_descriptor *cdh); -psb_d_t psb_c_dminquotient(psb_c_dvector *xh,psb_c_dvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspscal(psb_d_t alpha, psb_c_dspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_dspscalpid(psb_d_t alpha, psb_c_dspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_dspaxpby(psb_d_t alpha, psb_c_dspmat *ah, psb_d_t beta, psb_c_dspmat *bh, psb_c_descriptor *cdh); - - -#ifdef __cplusplus -} -#endif /* __cplusplus */ - -#endif diff --git a/cbind/psb_c_sbase.h b/cbind/psb_c_sbase.h deleted file mode 100644 index f132e707..00000000 --- a/cbind/psb_c_sbase.h +++ /dev/null @@ -1,110 +0,0 @@ -#ifndef PSB_C_SBASE_ -#define PSB_C_SBASE_ -#include "psb_c_base.h" - -#ifdef __cplusplus -extern "C" { -#endif - -typedef struct PSB_C_SVECTOR { - void *svector; -} psb_c_svector; - -typedef struct PSB_C_SSPMAT { - void *sspmat; -} psb_c_sspmat; - - -/* dense vectors */ -psb_c_svector* psb_c_new_svector(); -psb_i_t psb_c_svect_get_nrows(psb_c_svector *xh); -psb_s_t *psb_c_svect_get_cpy( psb_c_svector *xh); -psb_i_t psb_c_svect_f_get_cpy(psb_s_t *v, psb_c_svector *xh); -psb_i_t psb_c_svect_zero(psb_c_svector *xh); -psb_s_t *psb_c_svect_f_get_pnt( psb_c_svector *xh); -psb_i_t psb_c_svect_clone(psb_c_svector *xh,psb_c_svector *yh); - -psb_i_t psb_c_sgeall(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeall_remote(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeall_remote_options(psb_c_svector *xh, psb_c_descriptor *cdh, - psb_i_t bldmode, psb_i_t duple); -psb_i_t psb_c_sgeins(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, - psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, - psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeasb_options(psb_c_svector *xh, psb_c_descriptor *cdh, psb_i_t dupl); -psb_i_t psb_c_sgeasb_options_format(psb_c_svector *xh, psb_c_descriptor *cdh, - const char *fmt, psb_i_t dupl); -psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd); - -/* sparse matrices*/ -psb_c_sspmat* psb_c_new_sspmat(); -psb_i_t psb_c_sspall(psb_c_sspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspall_remote(psb_c_sspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspasb(psb_c_sspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspfree(psb_c_sspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, - const psb_s_t *val, psb_c_sspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_smat_get_nrows(psb_c_sspmat *mh); -psb_i_t psb_c_smat_get_ncols(psb_c_sspmat *mh); -psb_l_t psb_c_snnz(psb_c_sspmat *mh,psb_c_descriptor *cdh); -bool psb_c_sis_matupd(psb_c_sspmat *mh,psb_c_descriptor *cdh); -bool psb_c_sis_matasb(psb_c_sspmat *mh,psb_c_descriptor *cdh); -bool psb_c_sis_matbld(psb_c_sspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_sset_matupd(psb_c_sspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_sset_matasb(psb_c_sspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_sset_matbld(psb_c_sspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_scopy_mat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_c_descriptor *cdh); - - psb_i_t psb_c_sspasb_opt(psb_c_sspmat *mh, psb_c_descriptor *cdh, - const char *afmt, psb_i_t upd, psb_i_t dupl); -psb_i_t psb_c_ssprn(psb_c_sspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name); -psb_i_t psb_c_svect_set_scal(psb_c_svector *xh, psb_s_t val); -psb_i_t psb_c_svect_set_vect(psb_c_svector *xh, psb_s_t *val, psb_i_t n); - -/* psblas computational routines */ -psb_s_t psb_c_sgedot(psb_c_svector *xh, psb_c_svector *yh, psb_c_descriptor *cdh); -psb_s_t psb_c_sgenrm2(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_sgeamax(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_sgeasum(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_sgenrmi(psb_c_sspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeaxpby(psb_s_t alpha, psb_c_svector *xh, - psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeaxpbyz(psb_s_t alpha, psb_c_svector *xh, - psb_s_t beta, psb_c_svector *yh, psb_c_svector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspmm(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh, - psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspmm_opt(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh, - psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh, - char *trans, bool doswap); -psb_i_t psb_c_sspsm(psb_s_t alpha, psb_c_sspmat *th, psb_c_svector *xh, - psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); -/* Additional computational routines */ -psb_i_t psb_c_sgemlt(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_sgemlt2(psb_s_t alpha, psb_c_svector *xh, psb_c_svector *yh, psb_s_t beta, psb_c_svector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgediv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_sgediv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_sgediv2(psb_c_svector *xh,psb_c_svector *yh,psb_c_svector *zh,psb_c_descriptor *cdh); -psb_i_t psb_c_sgediv2_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_svector *zh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_sgeinv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_sgeinv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_sgeabs(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_sgecmp(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh); -bool psb_c_sgecmpmat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_s_t tol,psb_c_descriptor *cdh); -bool psb_c_sgecmpmat_val(psb_c_sspmat *ah,psb_s_t val,psb_s_t tol,psb_c_descriptor *cdh); -psb_i_t psb_c_sgeaddconst(psb_c_svector *xh,psb_s_t bh,psb_c_svector *zh,psb_c_descriptor *cdh); -psb_s_t psb_c_sgenrm2_weight(psb_c_svector *xh,psb_c_svector *wh,psb_c_descriptor *cdh); -psb_s_t psb_c_sgenrm2_weightmask(psb_c_svector *xh,psb_c_svector *wh,psb_c_svector *idvh,psb_c_descriptor *cdh); -psb_i_t psb_c_smask(psb_c_svector *ch,psb_c_svector *xh,psb_c_svector *mh, bool *t, psb_c_descriptor *cdh); -psb_s_t psb_c_sgemin(psb_c_svector *xh,psb_c_descriptor *cdh); -psb_i_t psb_c_sspscal(psb_s_t alpha, psb_c_sspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_sspscalpid(psb_s_t alpha, psb_c_sspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_sspaxpby(psb_s_t alpha, psb_c_sspmat *ah, psb_s_t beta, psb_c_sspmat *bh, psb_c_descriptor *cdh); -#ifdef __cplusplus -} -#endif /* __cplusplus */ - -#endif diff --git a/cbind/psb_c_zbase.h b/cbind/psb_c_zbase.h deleted file mode 100644 index 40bff485..00000000 --- a/cbind/psb_c_zbase.h +++ /dev/null @@ -1,110 +0,0 @@ -#ifndef PSB_C_ZBASE_ -#define PSB_C_ZBASE_ -#include "psb_c_base.h" - -#ifdef __cplusplus -extern "C" { -#endif - -typedef struct PSB_C_ZVECTOR { - void *zvector; -} psb_c_zvector; - -typedef struct PSB_C_ZSPMAT { - void *zspmat; -} psb_c_zspmat; - - -/* dense vectors */ -psb_c_zvector* psb_c_new_zvector(); -psb_i_t psb_c_zvect_get_nrows(psb_c_zvector *xh); -psb_z_t *psb_c_zvect_get_cpy( psb_c_zvector *xh); -psb_i_t psb_c_zvect_f_get_cpy(psb_z_t *v, psb_c_zvector *xh); -psb_i_t psb_c_zvect_zero(psb_c_zvector *xh); -psb_z_t *psb_c_zvect_f_get_pnt( psb_c_zvector *xh); -psb_i_t psb_c_zvect_clone(psb_c_zvector *xh,psb_c_zvector *yh); - -psb_i_t psb_c_zgeall(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeall_remote(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeall_remote_options(psb_c_zvector *xh, psb_c_descriptor *cdh, - psb_i_t bldmode, psb_i_t duple); -psb_i_t psb_c_zgeins(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val, - psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val, - psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeasb(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeasb_options(psb_c_zvector *xh, psb_c_descriptor *cdh, psb_i_t dupl); -psb_i_t psb_c_zgeasb_options_format(psb_c_zvector *xh, psb_c_descriptor *cdh, - const char *fmt, psb_i_t dupl); -psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd); - -/* sparse matrices*/ -psb_c_zspmat* psb_c_new_zspmat(); -psb_i_t psb_c_zspall(psb_c_zspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspall_remote(psb_c_zspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspasb(psb_c_zspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspfree(psb_c_zspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, - const psb_z_t *val, psb_c_zspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_zmat_get_nrows(psb_c_zspmat *mh); -psb_i_t psb_c_zmat_get_ncols(psb_c_zspmat *mh); -psb_l_t psb_c_znnz(psb_c_zspmat *mh,psb_c_descriptor *cdh); -bool psb_c_zis_matupd(psb_c_zspmat *mh,psb_c_descriptor *cdh); -bool psb_c_zis_matasb(psb_c_zspmat *mh,psb_c_descriptor *cdh); -bool psb_c_zis_matbld(psb_c_zspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_zset_matupd(psb_c_zspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_zset_matasb(psb_c_zspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_zset_matbld(psb_c_zspmat *mh,psb_c_descriptor *cdh); -psb_i_t psb_c_zcopy_mat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_c_descriptor *cdh); - - -psb_i_t psb_c_zspasb_opt(psb_c_zspmat *mh, psb_c_descriptor *cdh, - const char *afmt, psb_i_t upd, psb_i_t dupl); -psb_i_t psb_c_zsprn(psb_c_zspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name); -psb_i_t psb_c_zvect_set_scal(psb_c_zvector *xh, psb_z_t val); -psb_i_t psb_c_zvect_set_vect(psb_c_zvector *xh, psb_z_t *val, psb_i_t n); - -/* psblas computational routines */ -psb_z_t psb_c_zgedot(psb_c_zvector *xh, psb_c_zvector *yh, psb_c_descriptor *cdh); -psb_d_t psb_c_zgenrm2(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_zgeamax(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_zgeasum(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_zgenrmi(psb_c_zspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeaxpby(psb_z_t alpha, psb_c_zvector *xh, - psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeaxpbyz(psb_z_t alpha, psb_c_zvector *xh, - psb_z_t beta, psb_c_zvector *yh, psb_c_zvector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspmm(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh, - psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspmm_opt(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh, - psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh, - char *trans, bool doswap); -psb_i_t psb_c_zspsm(psb_z_t alpha, psb_c_zspmat *th, psb_c_zvector *xh, - psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); -/* Additional computational routines */ -psb_i_t psb_c_zgemlt(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_zgemlt2(psb_z_t alpha, psb_c_zvector *xh, psb_c_zvector *yh, psb_z_t beta, psb_c_zvector *zh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgediv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_zgediv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_zgediv2(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_zvector *zh,psb_c_descriptor *cdh); -psb_i_t psb_c_zgediv2_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_zvector *zh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_zgeinv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_zgeinv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh, bool flag); -psb_i_t psb_c_zgeabs(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); -psb_i_t psb_c_zgecmp(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh); -bool psb_c_zgecmpmat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_d_t tol,psb_c_descriptor *cdh); -bool psb_c_zgecmpmat_val(psb_c_zspmat *ah,psb_z_t val,psb_d_t tol,psb_c_descriptor *cdh); -psb_i_t psb_c_zgeaddconst(psb_c_zvector *xh,psb_z_t bh,psb_c_zvector *zh,psb_c_descriptor *cdh); -psb_d_t psb_c_zgenrm2_weight(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_descriptor *cdh); -psb_d_t psb_c_zgenrm2_weightmask(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_zvector *idvh,psb_c_descriptor *cdh); -psb_i_t psb_c_zspscal(psb_z_t alpha, psb_c_zspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_zspscalpid(psb_z_t alpha, psb_c_zspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_zspaxpby(psb_z_t alpha, psb_c_zspmat *ah, psb_z_t beta, psb_c_zspmat *bh, psb_c_descriptor *cdh); - -#ifdef __cplusplus -} -#endif /* __cplusplus */ - -#endif diff --git a/test/halo_new/Makefile b/test/halo_new/Makefile index 840f433e..d85de454 100644 --- a/test/halo_new/Makefile +++ b/test/halo_new/Makefile @@ -12,10 +12,11 @@ LDLIBS=$(PSBLDLIBS) FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). TOBJS=test_halo_new.o +TOBJS_API=test_halo_new_api.o EXEDIR=./runs -all: runsd test_halo_new +all: runsd test_halo_new test_halo_new_api runsd: (if test ! -d runs ; then mkdir runs; fi) @@ -24,8 +25,12 @@ test_halo_new: $(TOBJS) $(FLINK) $(LOPT) $(TOBJS) -o test_halo_new $(PSBLAS_LIB) $(LDLIBS) /bin/mv test_halo_new $(EXEDIR) +test_halo_new_api: $(TOBJS_API) + $(FLINK) $(LOPT) $(TOBJS_API) -o test_halo_new_api $(PSBLAS_LIB) $(LDLIBS) + /bin/mv test_halo_new_api $(EXEDIR) + clean: - /bin/rm -f $(TOBJS) *$(.mod) $(EXEDIR)/test_halo_new + /bin/rm -f $(TOBJS) $(TOBJS_API) *$(.mod) $(EXEDIR)/test_halo_new $(EXEDIR)/test_halo_new_api lib: (cd ../../; make library) diff --git a/test/halo_new/test_halo_new.F90 b/test/halo_new/test_halo_new.F90 index 5e82c691..8fa51de9 100644 --- a/test/halo_new/test_halo_new.F90 +++ b/test/halo_new/test_halo_new.F90 @@ -21,48 +21,68 @@ program test_halo_new implicit none ! ---- parameters ---- - integer(psb_ipk_), parameter :: idim = 10 ! grid idim x idim x idim + integer(psb_ipk_) :: idim + integer(psb_ipk_) :: argc + character(len=32) :: arg ! ---- descriptor / context ---- - type(psb_ctxt_type) :: ctxt - type(psb_desc_type) :: desc_a - integer(psb_ipk_) :: iam, np, info, i, nr, nlr - integer(psb_lpk_) :: m, nt - integer(psb_lpk_), allocatable :: myidx(:) + type(psb_ctxt_type) :: ctxt + type(psb_desc_type) :: desc_a + integer(psb_ipk_) :: my_rank, np, info, i, nr, number_of_local_rows + integer(psb_lpk_) :: m, nt + integer(psb_lpk_), allocatable :: myidx(:) ! ---- vectors ---- - type(psb_d_vect_type) :: v_baseline, v_neighbor + type(psb_d_vect_type) :: v_baseline, v_neighbor ! ---- temporary / comparison arrays ---- - real(psb_dpk_), allocatable :: vals(:) - real(psb_dpk_), allocatable :: res_bl(:), res_nb(:) - real(psb_dpk_), allocatable :: expected(:) + real(psb_dpk_), allocatable :: vals(:) + real(psb_dpk_), allocatable :: result_baseline(:), result_neighbor(:) + real(psb_dpk_), allocatable :: expected(:) - ! ---- work buffer for psi_swapdata ---- - real(psb_dpk_), allocatable :: work(:) + ! ---- work buffer for psi_swapdata (required by the interface) ---- + real(psb_dpk_), allocatable :: work(:) ! ---- halo index bookkeeping ---- - integer(psb_ipk_) :: nrow, ncol, totxch, idxs, idxr, data_ - class(psb_i_base_vect_type), pointer :: d_vidx + integer(psb_ipk_) :: nrow, ncol, num_neighbors, send_indexes, receive_indexes + class(psb_i_base_vect_type), pointer :: halo_indexes ! ---- error / reporting ---- - integer(psb_ipk_) :: n_pass, n_total, imode - real(psb_dpk_) :: err, tol - integer(psb_lpk_), allocatable :: glob_col(:) - character(len=40) :: name + integer(psb_ipk_) :: n_pass, n_total, imode + real(psb_dpk_) :: err, tol + integer(psb_lpk_), allocatable :: glob_col(:) + character(len=40) :: name name = 'test_halo_new' tol = 1.0d-12 n_pass = 0 n_total = 0 + ! ---- parse command-line argument for idim ---- + idim = 10 + argc = command_argument_count() + do i = 1, argc + call get_command_argument(i, arg) + if (trim(arg) == '--dim') then + if (i < argc) then + call get_command_argument(i+1, arg) + read(arg, *) idim + exit + end if + end if + end do + + if (idim <= 0) then + write(*,*) 'Invalid dimension specified. Usage: --dim ' + call psb_abort(ctxt) + end if ! ================================================================== ! 1. Initialise MPI / PSBLAS context ! ================================================================== call psb_init(ctxt) - call psb_info(ctxt, iam, np) + call psb_info(ctxt, my_rank, np) - if (iam == 0) then + if (my_rank == 0) then write(psb_out_unit,'("================================================")') write(psb_out_unit,'(" Test: D-type halo baseline vs neighbor topo")') write(psb_out_unit,'(" Processes : ",i0)') np @@ -75,18 +95,18 @@ program test_halo_new ! ================================================================== m = (1_psb_lpk_ * idim) * idim * idim nt = (m + np - 1) / np - nr = max(0, min(int(nt,psb_ipk_), int(m - (iam * nt),psb_ipk_))) + nr = max(0, min(int(nt,psb_ipk_), int(m - (my_rank * nt),psb_ipk_))) call psb_cdall(ctxt, desc_a, info, nl=nr) if (info /= psb_success_) then - write(psb_err_unit,*) iam, 'cdall error:', info + write(psb_err_unit,*) my_rank, 'cdall error:', info call psb_abort(ctxt) end if myidx = desc_a%get_global_indices() - nlr = size(myidx) + number_of_local_rows = size(myidx) - do i = 1, nlr + do i = 1, number_of_local_rows call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)/), desc_a, info) if (myidx(i) > 1) & & call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)-1/), desc_a, info) @@ -106,7 +126,7 @@ program test_halo_new call psb_cdasb(desc_a, info) if (info /= psb_success_) then - write(psb_err_unit,*) iam, 'cdasb error:', info + write(psb_err_unit,*) my_rank, 'cdasb error:', info call psb_abort(ctxt) end if @@ -124,7 +144,7 @@ program test_halo_new ! Fill owned entries with the global index value allocate(vals(ncol)) vals = dzero - do i = 1, nlr + do i = 1, number_of_local_rows vals(i) = real(myidx(i), psb_dpk_) end do call v_baseline%set_vect(vals) @@ -145,24 +165,23 @@ program test_halo_new ! ================================================================== ! 5. Retrieve halo index list (same list used by both paths) ! ================================================================== - data_ = psb_comm_halo_ - call desc_a%get_list_p(data_, d_vidx, totxch, idxr, idxs, info) + call desc_a%get_list_p(psb_comm_halo_, halo_indexes, num_neighbors, receive_indexes, send_indexes, info) if (info /= psb_success_) then - write(psb_err_unit,*) iam, 'get_list_p error:', info + write(psb_err_unit,*) my_rank, 'get_list_p error:', info call psb_abort(ctxt) end if allocate(work(nrow)) - work = dzero ! ================================================================== ! 6. Baseline halo exchange (Isend/Irecv in one call) ! ================================================================== imode = IOR(psb_swap_send_, psb_swap_recv_) + ! v_baseline%v is a psb_d_base_vect_type call psi_swapdata(ctxt, desc_a%get_mpic(), imode, dzero, & - & v_baseline%v, d_vidx, totxch, idxs, idxr, work, info) + & v_baseline%v, halo_indexes, num_neighbors, send_indexes, receive_indexes, work, info) if (info /= psb_success_) then - write(psb_err_unit,*) iam, 'baseline swap error:', info + write(psb_err_unit,*) my_rank, 'baseline swap error:', info call psb_abort(ctxt) end if @@ -170,30 +189,30 @@ program test_halo_new ! 7. Neighbor topology halo exchange (start + wait) ! ================================================================== call psi_swapdata(ctxt, desc_a%get_mpic(), psb_swap_start_, dzero, & - & v_neighbor%v, d_vidx, totxch, idxs, idxr, work, info) + & v_neighbor%v, halo_indexes, num_neighbors, send_indexes, receive_indexes, work, info) if (info /= psb_success_) then - write(psb_err_unit,*) iam, 'neighbor start error:', info + write(psb_err_unit,*) my_rank, 'neighbor start error:', info call psb_abort(ctxt) end if call psi_swapdata(ctxt, desc_a%get_mpic(), psb_swap_wait_, dzero, & - & v_neighbor%v, d_vidx, totxch, idxs, idxr, work, info) + & v_neighbor%v, halo_indexes, num_neighbors, send_indexes, receive_indexes, work, info) if (info /= psb_success_) then - write(psb_err_unit,*) iam, 'neighbor wait error:', info + write(psb_err_unit,*) my_rank, 'neighbor wait error:', info call psb_abort(ctxt) end if ! ================================================================== ! 8. Extract results and compare ! ================================================================== - res_bl = v_baseline%get_vect() - res_nb = v_neighbor%get_vect() + result_baseline = v_baseline%get_vect() + result_neighbor = v_neighbor%get_vect() ! ---- Test 1: cross-check baseline vs neighbor (all entries) ---- n_total = n_total + 1 - err = maxval(abs(res_bl(1:ncol) - res_nb(1:ncol))) + err = maxval(abs(result_baseline(1:ncol) - result_neighbor(1:ncol))) call psb_amx(ctxt, err) - if (iam == 0) then + if (my_rank == 0) then if (err < tol) then write(psb_out_unit,'(" [PASS] cross-check baseline vs neighbor : err = ",es12.5)') err n_pass = n_pass + 1 @@ -204,9 +223,9 @@ program test_halo_new ! ---- Test 2: baseline absolute correctness (halo = global index) ---- n_total = n_total + 1 - err = maxval(abs(res_bl(1:ncol) - expected(1:ncol))) + err = maxval(abs(result_baseline(1:ncol) - expected(1:ncol))) call psb_amx(ctxt, err) - if (iam == 0) then + if (my_rank == 0) then if (err < tol) then write(psb_out_unit,'(" [PASS] baseline absolute correctness : err = ",es12.5)') err n_pass = n_pass + 1 @@ -217,9 +236,9 @@ program test_halo_new ! ---- Test 3: neighbor absolute correctness (halo = global index) ---- n_total = n_total + 1 - err = maxval(abs(res_nb(1:ncol) - expected(1:ncol))) + err = maxval(abs(result_neighbor(1:ncol) - expected(1:ncol))) call psb_amx(ctxt, err) - if (iam == 0) then + if (my_rank == 0) then if (err < tol) then write(psb_out_unit,'(" [PASS] neighbor absolute correctness : err = ",es12.5)') err n_pass = n_pass + 1 @@ -231,20 +250,20 @@ program test_halo_new ! ---- Test 4: repeat neighbor exchange (topology reuse) ---- ! Reset halo entries to zero, run again, and check do i = nrow+1, ncol - res_nb(i) = dzero + result_neighbor(i) = dzero end do - call v_neighbor%set_vect(res_nb) + call v_neighbor%set_vect(result_neighbor) call psi_swapdata(ctxt, desc_a%get_mpic(), psb_swap_start_, dzero, & - & v_neighbor%v, d_vidx, totxch, idxs, idxr, work, info) + & v_neighbor%v, halo_indexes, num_neighbors, send_indexes, receive_indexes, work, info) call psi_swapdata(ctxt, desc_a%get_mpic(), psb_swap_wait_, dzero, & - & v_neighbor%v, d_vidx, totxch, idxs, idxr, work, info) + & v_neighbor%v, halo_indexes, num_neighbors, send_indexes, receive_indexes, work, info) - res_nb = v_neighbor%get_vect() + result_neighbor = v_neighbor%get_vect() n_total = n_total + 1 - err = maxval(abs(res_nb(1:ncol) - expected(1:ncol))) + err = maxval(abs(result_neighbor(1:ncol) - expected(1:ncol))) call psb_amx(ctxt, err) - if (iam == 0) then + if (my_rank == 0) then if (err < tol) then write(psb_out_unit,'(" [PASS] neighbor topology reuse : err = ",es12.5)') err n_pass = n_pass + 1 @@ -256,7 +275,7 @@ program test_halo_new ! ================================================================== ! 9. Summary ! ================================================================== - if (iam == 0) then + if (my_rank == 0) then write(psb_out_unit,'("================================================")') write(psb_out_unit,'(" Results: ",i0," / ",i0," tests passed")') n_pass, n_total if (n_pass == n_total) then @@ -270,7 +289,7 @@ program test_halo_new ! ================================================================== ! 10. Cleanup ! ================================================================== - deallocate(res_bl, res_nb, expected, glob_col, work) + deallocate(result_baseline, result_neighbor, expected, glob_col, work) call psb_gefree(v_baseline, desc_a, info) call psb_gefree(v_neighbor, desc_a, info) call psb_cdfree(desc_a, info) diff --git a/test/halo_new/test_halo_new_api.F90 b/test/halo_new/test_halo_new_api.F90 new file mode 100644 index 00000000..f1451098 --- /dev/null +++ b/test/halo_new/test_halo_new_api.F90 @@ -0,0 +1,285 @@ +! +! Test program for D-type halo exchange: baseline vs neighbor topology. +! +! This test uses the psb_halo_new interface with encapsulated vectors +! to compare the two communication paths: +! +! 1. Baseline (Isend/Irecv) : comm_type = 0 (psb_comm_type_isend_) +! 2. Neighbor topology (Ineighbor_alltoallv) : comm_type = 1 (psb_comm_type_neigh_a2av_) +! +! NOTE: The neighbor topology communication requires encapsulated vectors +! (psb_d_vect_type). +! +! It builds a 3D block-partitioned descriptor with a 7-point stencil, +! fills owned entries with their global index, performs halo exchange +! via both paths, then checks: +! (a) The two paths produce identical results (cross-check) +! (b) Every halo entry equals the global index of its source (absolute check) +! +! Run with: mpirun -np

./test_halo_new_api +! +program test_halo_new_api + use psb_base_mod + implicit none + + ! ---- grid parameters ---- + integer(psb_ipk_) :: idim + integer(psb_ipk_) :: argc + character(len=32) :: arg + + ! ---- parallel context ---- + type(psb_ctxt_type) :: ctxt + type(psb_desc_type) :: desc_a + integer(psb_ipk_) :: my_rank, np, info, i, nr, nlr + integer(psb_lpk_) :: m, nt + integer(psb_lpk_), allocatable :: myidx(:) + + ! ---- encapsulated vectors for halo exchange ---- + ! NOTE: Must use psb_d_vect_type (not plain arrays) for neighbor topology to work + ! No work buffer needed for psb_halo + type(psb_d_vect_type) :: v_baseline, v_neighbor + + ! ---- temporary arrays ---- + real(psb_dpk_), allocatable :: vals(:) + real(psb_dpk_), allocatable :: res_bl(:), res_nb(:) + + ! ---- local sizes ---- + integer(psb_ipk_) :: nrow, ncol + + ! ---- communication type constants ---- + integer(psb_ipk_), parameter :: psb_comm_type_isend_ = 0 + integer(psb_ipk_), parameter :: psb_comm_type_neigh_a2av_ = 1 + + ! ---- test results ---- + integer(psb_ipk_) :: n_pass, n_total + real(psb_dpk_) :: err, tol + integer(psb_lpk_), allocatable :: glob_col(:) + real(psb_dpk_), allocatable :: expected(:) + character(len=40) :: name + + name = 'test_halo_new_api' + tol = 1.0d-12 + n_pass = 0 + n_total = 0 + + ! ---- parse command-line argument for idim ---- + idim = 10 + argc = command_argument_count() + do i = 1, argc + call get_command_argument(i, arg) + if (trim(arg) == '--dim') then + if (i < argc) then + call get_command_argument(i+1, arg) + read(arg, *) idim + exit + end if + end if + end do + + if (idim <= 0) then + write(*,*) 'Invalid grid size specified. Usage: --dim ' + call psb_abort(ctxt) + end if + + + + ! ================================================================== + ! 1. Initialise MPI / PSBLAS context + ! ================================================================== + call psb_init(ctxt) + call psb_info(ctxt, my_rank, np) + + if (my_rank == 0) then + write(psb_out_unit,'("================================================")') + write(psb_out_unit,'(" Test: D-type halo using psb_halo interface")') + write(psb_out_unit,'(" Processes : ",i0)') np + write(psb_out_unit,'(" Grid : ",i0," x ",i0," x ",i0)') idim, idim, idim + write(psb_out_unit,'("================================================")') + end if + + ! ================================================================== + ! 2. Build descriptor with 7-point stencil connectivity + ! ================================================================== + m = (1_psb_lpk_ * idim) * idim * idim + nt = (m + np - 1) / np + nr = max(0, min(int(nt,psb_ipk_), int(m - (my_rank * nt),psb_ipk_))) + + call psb_cdall(ctxt, desc_a, info, nl=nr) + if (info /= psb_success_) then + write(psb_err_unit,*) my_rank, 'cdall error:', info + call psb_abort(ctxt) + end if + + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + ! Insert 7-point stencil connectivity for 3D grid + do i = 1, nlr + call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)/), desc_a, info) + if (myidx(i) > 1) & + & call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)-1/), desc_a, info) + if (myidx(i) < m) & + & call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)+1/), desc_a, info) + if (myidx(i) > idim) & + & call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)-idim/), desc_a, info) + if (myidx(i) + idim <= m) & + & call psb_cdins(1_psb_ipk_, (/myidx(i)/), (/myidx(i)+idim/), desc_a, info) + if (myidx(i) > int(idim,psb_lpk_)*idim) & + & call psb_cdins(1_psb_ipk_, (/myidx(i)/), & + & (/myidx(i) - int(idim,psb_lpk_)*idim/), desc_a, info) + if (myidx(i) + int(idim,psb_lpk_)*idim <= m) & + & call psb_cdins(1_psb_ipk_, (/myidx(i)/), & + & (/myidx(i) + int(idim,psb_lpk_)*idim/), desc_a, info) + end do + + call psb_cdasb(desc_a, info) + if (info /= psb_success_) then + write(psb_err_unit,*) my_rank, 'cdasb error:', info + call psb_abort(ctxt) + end if + + nrow = desc_a%get_local_rows() ! owned + ncol = desc_a%get_local_cols() ! owned + halo + + ! ================================================================== + ! 3. Allocate encapsulated vectors and fill owned entries + ! ================================================================== + call psb_geall(v_baseline, desc_a, info) + call psb_geall(v_neighbor, desc_a, info) + call psb_geasb(v_baseline, desc_a, info, scratch=.true.) + call psb_geasb(v_neighbor, desc_a, info, scratch=.true.) + + allocate(vals(ncol)) + vals = dzero + do i = 1, nlr + vals(i) = real(myidx(i), psb_dpk_) + end do + call v_baseline%set_vect(vals) + call v_neighbor%set_vect(vals) + deallocate(vals) + + ! ================================================================== + ! 4. Build the expected result for halo positions + ! global_column_indices(j) = global index of local column j + ! After halo exchange every position j should hold global_column_indices(j). + ! ================================================================== + allocate(glob_col(ncol), expected(ncol)) + glob_col = desc_a%get_global_indices(owned=.false.) + do i = 1, ncol + expected(i) = real(glob_col(i), psb_dpk_) + end do + + ! ================================================================== + ! 5. Baseline halo exchange (Isend/Irecv) + ! Uses comm_type = 0 (psb_comm_type_isend_) + ! ================================================================== + call psb_halo_new(v_baseline, desc_a, info, comm_type=psb_comm_type_isend_) + if (info /= psb_success_) then + write(psb_err_unit,*) my_rank, 'baseline halo error:', info + call psb_abort(ctxt) + end if + + ! ================================================================== + ! 6. Neighbor topology halo exchange + ! Uses comm_type = 1 (psb_comm_type_neigh_a2av_) + ! ================================================================== + call psb_halo_new(v_neighbor, desc_a, info, comm_type=psb_comm_type_neigh_a2av_) + if (info /= psb_success_) then + write(psb_err_unit,*) my_rank, 'neighbor halo error:', info + call psb_abort(ctxt) + end if + + ! ================================================================== + ! 7. Extract results and compare + ! ================================================================== + res_bl = v_baseline%get_vect() + res_nb = v_neighbor%get_vect() + + ! ---- Test 1: cross-check baseline vs neighbor (all entries) ---- + n_total = n_total + 1 + err = maxval(abs(res_bl(1:ncol) - res_nb(1:ncol))) + call psb_amx(ctxt, err) + if (my_rank == 0) then + if (err < tol) then + write(psb_out_unit,'(" [PASS] cross-check baseline vs neighbor : err = ",es12.5)') err + n_pass = n_pass + 1 + else + write(psb_out_unit,'(" [FAIL] cross-check baseline vs neighbor : err = ",es12.5)') err + end if + end if + + ! ---- Test 2: baseline absolute correctness (halo = global index) ---- + n_total = n_total + 1 + err = maxval(abs(res_bl(1:ncol) - expected(1:ncol))) + call psb_amx(ctxt, err) + if (my_rank == 0) then + if (err < tol) then + write(psb_out_unit,'(" [PASS] baseline absolute correctness : err = ",es12.5)') err + n_pass = n_pass + 1 + else + write(psb_out_unit,'(" [FAIL] baseline absolute correctness : err = ",es12.5)') err + end if + end if + + ! ---- Test 3: neighbor absolute correctness (halo = global index) ---- + n_total = n_total + 1 + err = maxval(abs(res_nb(1:ncol) - expected(1:ncol))) + call psb_amx(ctxt, err) + if (my_rank == 0) then + if (err < tol) then + write(psb_out_unit,'(" [PASS] neighbor absolute correctness : err = ",es12.5)') err + n_pass = n_pass + 1 + else + write(psb_out_unit,'(" [FAIL] neighbor absolute correctness : err = ",es12.5)') err + end if + end if + + ! ---- Test 4: repeat neighbor exchange (topology reuse) ---- + do i = nrow+1, ncol + res_nb(i) = dzero + end do + call v_neighbor%set_vect(res_nb) + + call psb_halo_new(v_neighbor, desc_a, info, comm_type=psb_comm_type_neigh_a2av_) + if (info /= psb_success_) then + write(psb_err_unit,*) my_rank, 'neighbor halo reuse error:', info + call psb_abort(ctxt) + end if + + res_nb = v_neighbor%get_vect() + n_total = n_total + 1 + err = maxval(abs(res_nb(1:ncol) - expected(1:ncol))) + call psb_amx(ctxt, err) + if (my_rank == 0) then + if (err < tol) then + write(psb_out_unit,'(" [PASS] neighbor topology reuse : err = ",es12.5)') err + n_pass = n_pass + 1 + else + write(psb_out_unit,'(" [FAIL] neighbor topology reuse : err = ",es12.5)') err + end if + end if + + ! ================================================================== + ! 8. Summary + ! ================================================================== + if (my_rank == 0) then + write(psb_out_unit,'("================================================")') + write(psb_out_unit,'(" Results: ",i0," / ",i0," tests passed")') n_pass, n_total + if (n_pass == n_total) then + write(psb_out_unit,'(" STATUS: ALL PASSED")') + else + write(psb_out_unit,'(" STATUS: SOME FAILURES")') + end if + write(psb_out_unit,'("================================================")') + end if + + ! ================================================================== + ! 9. Cleanup + ! ================================================================== + deallocate(res_bl, res_nb, expected, glob_col) + call psb_gefree(v_baseline, desc_a, info) + call psb_gefree(v_neighbor, desc_a, info) + call psb_cdfree(desc_a, info) + call psb_exit(ctxt) + +end program test_halo_new_api