From 27e4cab5186b2586ec50765880c768cf99067115 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 14 Jul 2015 16:16:00 +0000 Subject: [PATCH] psblas: base/comm/psb_chalo.f90 base/comm/psb_dhalo.f90 base/comm/psb_shalo.f90 base/comm/psb_zhalo.f90 base/internals/psi_cswapdata.F90 base/internals/psi_cswaptran.F90 base/internals/psi_dswapdata.F90 base/internals/psi_dswaptran.F90 base/internals/psi_iswapdata.F90 base/internals/psi_iswaptran.F90 base/internals/psi_sswapdata.F90 base/internals/psi_sswaptran.F90 base/internals/psi_zswapdata.F90 base/internals/psi_zswaptran.F90 base/modules/psb_c_base_vect_mod.f90 base/modules/psb_c_comm_mod.f90 base/modules/psb_c_tools_mod.f90 base/modules/psb_c_vect_mod.F90 base/modules/psb_d_base_vect_mod.f90 base/modules/psb_d_comm_mod.f90 base/modules/psb_d_tools_mod.f90 base/modules/psb_d_vect_mod.F90 base/modules/psb_i_base_vect_mod.f90 base/modules/psb_i_comm_mod.f90 base/modules/psb_i_tools_mod.f90 base/modules/psb_i_vect_mod.F90 base/modules/psb_s_base_vect_mod.f90 base/modules/psb_s_comm_mod.f90 base/modules/psb_s_tools_mod.f90 base/modules/psb_s_vect_mod.F90 base/modules/psb_z_base_vect_mod.f90 base/modules/psb_z_comm_mod.f90 base/modules/psb_z_tools_mod.f90 base/modules/psb_z_vect_mod.F90 base/tools/psb_callc.f90 base/tools/psb_casb.f90 base/tools/psb_dallc.f90 base/tools/psb_dasb.f90 base/tools/psb_iallc.f90 base/tools/psb_iasb.f90 base/tools/psb_sallc.f90 base/tools/psb_sasb.f90 base/tools/psb_zallc.f90 base/tools/psb_zasb.f90 Set up full support for multivectors, step 1: define GEALL/GEASB/HALO. --- base/comm/psb_chalo.f90 | 140 +++++++++++ base/comm/psb_dhalo.f90 | 140 +++++++++++ base/comm/psb_shalo.f90 | 140 +++++++++++ base/comm/psb_zhalo.f90 | 140 +++++++++++ base/internals/psi_cswapdata.F90 | 341 +++++++++++++++++++++++++- base/internals/psi_cswaptran.F90 | 350 +++++++++++++++++++++++++++ base/internals/psi_dswapdata.F90 | 341 +++++++++++++++++++++++++- base/internals/psi_dswaptran.F90 | 350 +++++++++++++++++++++++++++ base/internals/psi_iswapdata.F90 | 341 +++++++++++++++++++++++++- base/internals/psi_iswaptran.F90 | 350 +++++++++++++++++++++++++++ base/internals/psi_sswapdata.F90 | 341 +++++++++++++++++++++++++- base/internals/psi_sswaptran.F90 | 350 +++++++++++++++++++++++++++ base/internals/psi_zswapdata.F90 | 341 +++++++++++++++++++++++++- base/internals/psi_zswaptran.F90 | 350 +++++++++++++++++++++++++++ base/modules/psb_c_base_vect_mod.f90 | 132 +++++++++- base/modules/psb_c_comm_mod.f90 | 13 +- base/modules/psb_c_tools_mod.f90 | 38 +++ base/modules/psb_c_vect_mod.F90 | 191 +++++++-------- base/modules/psb_d_base_vect_mod.f90 | 132 +++++++++- base/modules/psb_d_comm_mod.f90 | 13 +- base/modules/psb_d_tools_mod.f90 | 38 +++ base/modules/psb_d_vect_mod.F90 | 191 +++++++-------- base/modules/psb_i_base_vect_mod.f90 | 132 +++++++++- base/modules/psb_i_comm_mod.f90 | 13 +- base/modules/psb_i_tools_mod.f90 | 38 +++ base/modules/psb_i_vect_mod.F90 | 153 ++++++------ base/modules/psb_s_base_vect_mod.f90 | 132 +++++++++- base/modules/psb_s_comm_mod.f90 | 13 +- base/modules/psb_s_tools_mod.f90 | 38 +++ base/modules/psb_s_vect_mod.F90 | 191 +++++++-------- base/modules/psb_z_base_vect_mod.f90 | 132 +++++++++- base/modules/psb_z_comm_mod.f90 | 13 +- base/modules/psb_z_tools_mod.f90 | 38 +++ base/modules/psb_z_vect_mod.F90 | 191 +++++++-------- base/tools/psb_callc.f90 | 94 +++++++ base/tools/psb_casb.f90 | 90 +++++++ base/tools/psb_dallc.f90 | 94 +++++++ base/tools/psb_dasb.f90 | 90 +++++++ base/tools/psb_iallc.f90 | 94 +++++++ base/tools/psb_iasb.f90 | 90 +++++++ base/tools/psb_sallc.f90 | 94 +++++++ base/tools/psb_sasb.f90 | 90 +++++++ base/tools/psb_zallc.f90 | 94 +++++++ base/tools/psb_zasb.f90 | 90 +++++++ test/fileread/runs/dfs.inp | 6 +- 45 files changed, 6269 insertions(+), 504 deletions(-) diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index 4b18ec43..e829ebb0 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -529,3 +529,143 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) return end subroutine psb_chalo_vect + + +subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_chalo_multivect + use psi_mod + implicit none + + type(psb_c_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& + & err, liwork,data_ + complex(psb_spk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_chalov' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, 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 + + 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 + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + 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,czero,x%v,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,cone,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) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_chalo_multivect + diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index d19739be..4883fa96 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -529,3 +529,143 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) return end subroutine psb_dhalo_vect + + +subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_dhalo_multivect + use psi_mod + implicit none + + type(psb_d_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& + & err, liwork,data_ + real(psb_dpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_dhalov' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, 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 + + 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 + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + 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%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) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_dhalo_multivect + diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index f182b458..25793365 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -529,3 +529,143 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) return end subroutine psb_shalo_vect + + +subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_shalo_multivect + use psi_mod + implicit none + + type(psb_s_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& + & err, liwork,data_ + real(psb_spk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_shalov' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, 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 + + 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 + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + 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,szero,x%v,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,sone,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) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_shalo_multivect + diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 42658ff3..6e339141 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -529,3 +529,143 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) return end subroutine psb_zhalo_vect + + +subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_zhalo_multivect + use psi_mod + implicit none + + type(psb_z_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& + & err, liwork,data_ + complex(psb_dpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_zhalov' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, 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 + + 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 + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + 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,zzero,x%v,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,zone,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) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_zhalo_multivect + diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index f0d5d692..f9798abf 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -1010,7 +1010,6 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_cswapidxv - ! ! ! Subroutine: psi_cswapdata_vect @@ -1351,3 +1350,343 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_cswap_vidx_vect +! +! +! Subroutine: psi_cswapdata_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. +! +! +! +subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswapdata_multivect + use psb_c_base_multivect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_cswapdata_multivect + + +! +! +! Subroutine: psi_cswap_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_cswap_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_c_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_complex_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_cswap_vidx_multivect + diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 09488b91..61849cae 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -1379,4 +1379,354 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end subroutine psi_ctran_vidx_vect +! +! +! +! +! Subroutine: psi_cswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswaptran_multivect + use psb_c_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psi_cswaptran_multivect + + + +! +! +! Subroutine: psi_ctran_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ctran_vidx_multivect + use psb_error_mod + use psb_desc_mod + use psb_penv_mod + use psb_c_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psi_ctran_vidx_multivect + + + diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 44ff826d..d05253ea 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -1010,7 +1010,6 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_dswapidxv - ! ! ! Subroutine: psi_dswapdata_vect @@ -1351,3 +1350,343 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_dswap_vidx_vect +! +! +! Subroutine: psi_dswapdata_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. +! +! +! +subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_dswapdata_multivect + use psb_d_base_multivect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dswapdata_multivect + + +! +! +! Subroutine: psi_dswap_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_dswap_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_d_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dswap_vidx_multivect + diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 5dcd62fe..3872d6bc 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -1379,4 +1379,354 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end subroutine psi_dtran_vidx_vect +! +! +! +! +! Subroutine: psi_dswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_dswaptran_multivect + use psb_d_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psi_dswaptran_multivect + + + +! +! +! Subroutine: psi_dtran_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_dtran_vidx_multivect + use psb_error_mod + use psb_desc_mod + use psb_penv_mod + use psb_d_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psi_dtran_vidx_multivect + + + diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 423cf62c..f7bb6ed7 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -1010,7 +1010,6 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_iswapidxv - ! ! ! Subroutine: psi_iswapdata_vect @@ -1351,3 +1350,343 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_iswap_vidx_vect +! +! +! Subroutine: psi_iswapdata_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. +! +! +! +subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_iswapdata_multivect + use psb_i_base_multivect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iswapdata_multivect + + +! +! +! Subroutine: psi_iswap_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_iswap_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_i_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_int_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iswap_vidx_multivect + diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index 343f1c61..205ad54e 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -1379,4 +1379,354 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end subroutine psi_itran_vidx_vect +! +! +! +! +! Subroutine: psi_iswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_iswaptran_multivect + use psb_i_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psi_iswaptran_multivect + + + +! +! +! Subroutine: psi_itran_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_itran_vidx_multivect + use psb_error_mod + use psb_desc_mod + use psb_penv_mod + use psb_i_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_ipk_integer,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psi_itran_vidx_multivect + + + diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index eb211ffc..a90557b1 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -1010,7 +1010,6 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_sswapidxv - ! ! ! Subroutine: psi_sswapdata_vect @@ -1351,3 +1350,343 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_sswap_vidx_vect +! +! +! Subroutine: psi_sswapdata_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. +! +! +! +subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswapdata_multivect + use psb_s_base_multivect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sswapdata_multivect + + +! +! +! Subroutine: psi_sswap_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_sswap_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_s_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_real_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sswap_vidx_multivect + diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index b423f4a1..28a976d0 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -1379,4 +1379,354 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end subroutine psi_stran_vidx_vect +! +! +! +! +! Subroutine: psi_sswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswaptran_multivect + use psb_s_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psi_sswaptran_multivect + + + +! +! +! Subroutine: psi_stran_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_stran_vidx_multivect + use psb_error_mod + use psb_desc_mod + use psb_penv_mod + use psb_s_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psi_stran_vidx_multivect + + + diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index b81434a6..0eed2a59 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -1010,7 +1010,6 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_zswapidxv - ! ! ! Subroutine: psi_zswapdata_vect @@ -1351,3 +1350,343 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & return end subroutine psi_zswap_vidx_vect +! +! +! Subroutine: psi_zswapdata_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. +! +! +! +subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_zswapdata_multivect + use psb_z_base_multivect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zswapdata_multivect + + +! +! +! Subroutine: psi_zswap_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an exanspulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_zswap_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_z_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zswap_vidx_multivect + diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 710d6da9..a26a5c2f 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -1379,4 +1379,354 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end subroutine psi_ztran_vidx_vect +! +! +! +! +! Subroutine: psi_zswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_zswaptran_multivect + use psb_z_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psi_zswaptran_multivect + + + +! +! +! Subroutine: psi_ztran_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ztran_vidx_multivect + use psb_error_mod + use psb_desc_mod + use psb_penv_mod + use psb_z_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpik_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + integer(psb_ipk_) :: ierr(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(size(idx%v),info) + call y%new_comid(totxch,info) + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + ierr(1) = -2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + ierr(1) = iret + info=psb_err_mpi_error_ + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Then wait + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psi_ztran_vidx_multivect + + + diff --git a/base/modules/psb_c_base_vect_mod.f90 b/base/modules/psb_c_base_vect_mod.f90 index 0a9b0c88..47a170f4 100644 --- a/base/modules/psb_c_base_vect_mod.f90 +++ b/base/modules/psb_c_base_vect_mod.f90 @@ -1308,7 +1308,6 @@ contains end subroutine c_base_sctb_x - subroutine c_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n @@ -1357,6 +1356,8 @@ module psb_c_base_multivect_mod type psb_c_base_multivect_type !> Values. complex(psb_spk_), allocatable :: v(:,:) + complex(psb_spk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1438,17 +1439,31 @@ module psb_c_base_multivect_mod procedure, pass(x) :: absval1 => c_base_mlv_absval1 procedure, pass(x) :: absval2 => c_base_mlv_absval2 generic, public :: absval => absval1, absval2 -!!$ ! -!!$ ! Gather/scatter. These are needed for MPI interfacing. -!!$ ! May have to be reworked. -!!$ ! + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => c_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => c_base_mlv_new_buffer + procedure, nopass :: device_wait => c_base_mlv_device_wait + procedure, pass(x) :: free_buffer => c_base_mlv_free_buffer + procedure, pass(x) :: new_comid => c_base_mlv_new_comid + procedure, pass(x) :: free_comid => c_base_mlv_free_comid + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! procedure, pass(x) :: gthab => c_base_mlv_gthab procedure, pass(x) :: gthzv => c_base_mlv_gthzv procedure, pass(x) :: gthzv_x => c_base_mlv_gthzv_x - generic, public :: gth => gthab, gthzv, gthzv_x + procedure, pass(x) :: gthzbuf => c_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf procedure, pass(y) :: sctb => c_base_mlv_sctb procedure, pass(y) :: sctb_x => c_base_mlv_sctb_x - generic, public :: sct => sctb, sctb_x + procedure, pass(y) :: sctb_buf => c_base_mlv_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf end type psb_c_base_multivect_type interface psb_c_base_multivect @@ -2421,6 +2436,57 @@ contains end subroutine c_base_mlv_absval2 + + function c_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function c_base_mlv_use_buffer + + subroutine c_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine c_base_mlv_new_buffer + + subroutine c_base_mlv_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2,x%comid,info) + end subroutine c_base_mlv_new_comid + + + subroutine c_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine c_base_mlv_free_buffer + + subroutine c_base_mlv_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_c_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine c_base_mlv_free_comid + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2495,6 +2561,27 @@ contains end subroutine c_base_mlv_gthzv + ! + ! New comm internals impl. + ! + subroutine c_base_mlv_gthzbuf(i,n,idx,x) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + class(psb_c_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) + + end subroutine c_base_mlv_gthzbuf + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2533,5 +2620,36 @@ contains end subroutine c_base_mlv_sctb_x + subroutine c_base_mlv_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + complex(psb_spk_) :: beta + class(psb_c_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) + call y%set_host() + + end subroutine c_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_c_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine c_base_mlv_device_wait() + implicit none + + end subroutine c_base_mlv_device_wait + end module psb_c_base_multivect_mod diff --git a/base/modules/psb_c_comm_mod.f90 b/base/modules/psb_c_comm_mod.f90 index 712679bb..735412fe 100644 --- a/base/modules/psb_c_comm_mod.f90 +++ b/base/modules/psb_c_comm_mod.f90 @@ -32,8 +32,9 @@ module psb_c_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_ use psb_mat_mod, only : psb_cspmat_type - + use psb_c_vect_mod, only : psb_c_vect_type, psb_c_base_vect_type + use psb_c_multivect_mod, only : psb_c_multivect_type, psb_c_base_multivect_type interface psb_ovrl subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) @@ -96,6 +97,16 @@ module psb_c_comm_mod integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran end subroutine psb_chalo_vect + subroutine psb_chalo_multivect(x,desc_a,info,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 + 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 end interface psb_halo diff --git a/base/modules/psb_c_tools_mod.f90 b/base/modules/psb_c_tools_mod.f90 index 64fb0830..d26996f5 100644 --- a/base/modules/psb_c_tools_mod.f90 +++ b/base/modules/psb_c_tools_mod.f90 @@ -33,6 +33,7 @@ Module psb_c_tools_mod use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_ use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type, psb_i_vect_type use psb_c_mat_mod, only : psb_cspmat_type, psb_c_base_sparse_mat + use psb_c_multivect_mod, only : psb_c_base_multivect_type, psb_c_multivect_type interface psb_geall subroutine psb_calloc(x, desc_a, info, n, lb) @@ -67,6 +68,14 @@ Module psb_c_tools_mod integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), optional, intent(in) :: n, lb end subroutine psb_calloc_vect_r2 + subroutine psb_calloc_multivect(x, desc_a,info,n) + import + implicit none + type(psb_c_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_calloc_multivect end interface @@ -103,6 +112,16 @@ Module psb_c_tools_mod class(psb_c_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch end subroutine psb_casb_vect_r2 + subroutine psb_casb_multivect(x, desc_a, info,mold, scratch, n) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_casb_multivect end interface interface psb_gefree @@ -134,6 +153,13 @@ Module psb_c_tools_mod type(psb_c_vect_type), allocatable, intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_cfree_vect_r2 + subroutine psb_cfree_multivect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cfree_multivect end interface @@ -198,6 +224,18 @@ Module psb_c_tools_mod integer(psb_ipk_), optional, intent(in) :: dupl logical, intent(in), optional :: local end subroutine psb_cins_vect_r2 + subroutine psb_cins_multivect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_cins_multivect end interface interface psb_cdbldext diff --git a/base/modules/psb_c_vect_mod.F90 b/base/modules/psb_c_vect_mod.F90 index 869cb460..4699479b 100644 --- a/base/modules/psb_c_vect_mod.F90 +++ b/base/modules/psb_c_vect_mod.F90 @@ -129,50 +129,50 @@ module psb_c_vect_mod interface psb_set_vect_default module procedure psb_c_set_vect_default - end interface + end interface psb_set_vect_default interface psb_get_vect_default module procedure psb_c_get_vect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_c_set_vect_default(v) implicit none class(psb_c_base_vect_type), intent(in) :: v - + if (allocated(psb_c_base_vect_default)) then deallocate(psb_c_base_vect_default) end if allocate(psb_c_base_vect_default, mold=v) end subroutine psb_c_set_vect_default - + function psb_c_get_vect_default(v) result(res) implicit none class(psb_c_vect_type), intent(in) :: v class(psb_c_base_vect_type), pointer :: res - + res => psb_c_get_base_vect_default() - + end function psb_c_get_vect_default - + function psb_c_get_base_vect_default() result(res) implicit none class(psb_c_base_vect_type), pointer :: res - + if (.not.allocated(psb_c_base_vect_default)) then allocate(psb_c_base_vect_type :: psb_c_base_vect_default) end if res => psb_c_base_vect_default - + end function psb_c_get_base_vect_default - + subroutine c_vect_clone(x,y,info) implicit none class(psb_c_vect_type), intent(inout) :: x @@ -185,7 +185,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine c_vect_clone - + subroutine c_vect_bld_x(x,invect,mold) complex(psb_spk_), intent(in) :: invect(:) class(psb_c_vect_type), intent(inout) :: x @@ -259,20 +259,20 @@ contains class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine c_vect_set_scal subroutine c_vect_set_vect(x,val,first,last) class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine c_vect_set_vect @@ -327,7 +327,7 @@ contains class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v)) & & call x%free(info) @@ -354,7 +354,7 @@ contains integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) @@ -382,7 +382,7 @@ contains if (allocated(x%v)) & & call x%v%asb(n,info) - + end subroutine c_vect_asb subroutine c_vect_gthab(n,idx,alpha,x,beta,y) @@ -390,10 +390,10 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: alpha, beta, y(:) class(psb_c_vect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine c_vect_gthab subroutine c_vect_gthzv(n,idx,x,y) @@ -404,7 +404,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine c_vect_gthzv subroutine c_vect_sctb(n,idx,x,beta,y) @@ -412,7 +412,7 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:) class(psb_c_vect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -424,13 +424,13 @@ contains implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine c_vect_free subroutine c_vect_ins_a(n,irl,val,dupl,x,info) @@ -449,9 +449,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine c_vect_ins_a subroutine c_vect_ins_v(n,irl,val,dupl,x,info) @@ -501,73 +501,73 @@ contains subroutine c_vect_sync(x) implicit none class(psb_c_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine c_vect_sync subroutine c_vect_set_sync(x) implicit none class(psb_c_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_sync() - + end subroutine c_vect_set_sync subroutine c_vect_set_host(x) implicit none class(psb_c_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_host() - + end subroutine c_vect_set_host subroutine c_vect_set_dev(x) implicit none class(psb_c_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_dev() - + end subroutine c_vect_set_dev function c_vect_is_sync(x) result(res) implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_sync() - + end function c_vect_is_sync function c_vect_is_host(x) result(res) implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_host() - + end function c_vect_is_host function c_vect_is_dev(x) result(res) implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x - + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() - + end function c_vect_is_dev - + function c_vect_dot_v(n,x,y) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x, y @@ -586,13 +586,13 @@ contains complex(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n complex(psb_spk_) :: res - + res = czero if (allocated(x%v)) & & res = x%v%dot(n,y) - + end function c_vect_dot_a - + subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod implicit none @@ -601,7 +601,7 @@ contains class(psb_c_vect_type), intent(inout) :: y complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else @@ -618,13 +618,13 @@ contains class(psb_c_vect_type), intent(inout) :: y complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(y%v)) & & call y%v%axpby(m,alpha,x,beta,info) - + end subroutine c_vect_axpby_a - + subroutine c_vect_mlt_v(x, y, info) use psi_serial_mod implicit none @@ -651,7 +651,7 @@ contains info = 0 if (allocated(y%v)) & & call y%v%mlt(x,info) - + end subroutine c_vect_mlt_a @@ -668,7 +668,7 @@ contains info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) - + end subroutine c_vect_mlt_a_2 subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) @@ -717,7 +717,7 @@ contains integer(psb_ipk_) :: i, n info = 0 - + if (allocated(z%v).and.allocated(x%v)) & & call z%v%mlt(alpha,x%v,y,beta,info) @@ -728,14 +728,14 @@ contains implicit none class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha - + if (allocated(x%v)) call x%v%scal(alpha) end subroutine c_vect_scal subroutine c_vect_absval1(x) class(psb_c_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%absval() @@ -744,19 +744,19 @@ contains subroutine c_vect_absval2(x,y) class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y - + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(size(x%v%v)) call x%v%absval(y%v) end if end subroutine c_vect_absval2 - + function c_vect_nrm2(n,x) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (allocated(x%v)) then res = x%v%nrm2(n) else @@ -764,7 +764,7 @@ contains end if end function c_vect_nrm2 - + function c_vect_amax(n,x) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x @@ -792,7 +792,7 @@ contains end if end function c_vect_asum - + end module psb_c_vect_mod @@ -859,62 +859,63 @@ module psb_c_multivect_mod end type psb_c_multivect_type public :: psb_c_multivect, psb_c_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_c_base_multivect_type private interface psb_c_multivect module procedure constructor, size_const - end interface - + end interface psb_c_multivect + class(psb_c_base_multivect_type), allocatable, target,& & save, private :: psb_c_base_multivect_default interface psb_set_multivect_default module procedure psb_c_set_multivect_default - end interface + end interface psb_set_multivect_default interface psb_get_vect_default module procedure psb_c_get_multivect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_c_set_multivect_default(v) implicit none class(psb_c_base_multivect_type), intent(in) :: v - + if (allocated(psb_c_base_multivect_default)) then deallocate(psb_c_base_multivect_default) end if allocate(psb_c_base_multivect_default, mold=v) end subroutine psb_c_set_multivect_default - + function psb_c_get_multivect_default(v) result(res) implicit none class(psb_c_multivect_type), intent(in) :: v class(psb_c_base_multivect_type), pointer :: res - + res => psb_c_get_base_multivect_default() - + end function psb_c_get_multivect_default - + function psb_c_get_base_multivect_default() result(res) implicit none class(psb_c_base_multivect_type), pointer :: res - + if (.not.allocated(psb_c_base_multivect_default)) then allocate(psb_c_base_multivect_type :: psb_c_base_multivect_default) end if res => psb_c_base_multivect_default - + end function psb_c_get_base_multivect_default - + subroutine c_vect_clone(x,y,info) implicit none class(psb_c_multivect_type), intent(inout) :: x @@ -927,7 +928,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine c_vect_clone - + subroutine c_vect_bld_x(x,invect,mold) complex(psb_spk_), intent(in) :: invect(:,:) class(psb_c_multivect_type), intent(out) :: x @@ -993,19 +994,19 @@ contains subroutine c_vect_set_scal(x,val) class(psb_c_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine c_vect_set_scal subroutine c_vect_set_vect(x,val) class(psb_c_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val(:,:) - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine c_vect_set_vect @@ -1061,7 +1062,7 @@ contains res = 'NULL' if (allocated(x%v)) res = x%v%get_fmt() end function c_vect_get_fmt - + subroutine c_vect_all(m,n, x, info, mold) implicit none @@ -1069,7 +1070,7 @@ contains class(psb_c_multivect_type), intent(out) :: x class(psb_c_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (present(mold)) then #ifdef HAVE_MOLD allocate(x%v,stat=info,mold=mold) @@ -1093,7 +1094,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) @@ -1121,16 +1122,16 @@ contains if (allocated(x%v)) & & call x%v%asb(m,n,info) - + end subroutine c_vect_asb subroutine c_vect_sync(x) implicit none class(psb_c_multivect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine c_vect_sync subroutine c_vect_gthab(n,idx,alpha,x,beta,y) @@ -1138,10 +1139,10 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: alpha, beta, y(:) class(psb_c_multivect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine c_vect_gthab subroutine c_vect_gthzv(n,idx,x,y) @@ -1152,7 +1153,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine c_vect_gthzv subroutine c_vect_gthzv_x(i,n,idx,x,y) @@ -1164,7 +1165,7 @@ contains if (allocated(x%v)) & & call x%v%gth(i,n,idx,y) - + end subroutine c_vect_gthzv_x subroutine c_vect_sctb(n,idx,x,beta,y) @@ -1172,7 +1173,7 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:) class(psb_c_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -1184,7 +1185,7 @@ contains class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: beta, x(:) class(psb_c_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(i,n,idx,x,beta) @@ -1196,13 +1197,13 @@ contains implicit none class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine c_vect_free subroutine c_vect_ins(n,irl,val,dupl,x,info) @@ -1221,9 +1222,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine c_vect_ins @@ -1248,7 +1249,7 @@ contains end if end subroutine c_vect_cnv - + !!$ function c_vect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x, y diff --git a/base/modules/psb_d_base_vect_mod.f90 b/base/modules/psb_d_base_vect_mod.f90 index 67560d70..eaebdcfe 100644 --- a/base/modules/psb_d_base_vect_mod.f90 +++ b/base/modules/psb_d_base_vect_mod.f90 @@ -1308,7 +1308,6 @@ contains end subroutine d_base_sctb_x - subroutine d_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n @@ -1357,6 +1356,8 @@ module psb_d_base_multivect_mod type psb_d_base_multivect_type !> Values. real(psb_dpk_), allocatable :: v(:,:) + real(psb_dpk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1438,17 +1439,31 @@ module psb_d_base_multivect_mod procedure, pass(x) :: absval1 => d_base_mlv_absval1 procedure, pass(x) :: absval2 => d_base_mlv_absval2 generic, public :: absval => absval1, absval2 -!!$ ! -!!$ ! Gather/scatter. These are needed for MPI interfacing. -!!$ ! May have to be reworked. -!!$ ! + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => d_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => d_base_mlv_new_buffer + procedure, nopass :: device_wait => d_base_mlv_device_wait + procedure, pass(x) :: free_buffer => d_base_mlv_free_buffer + procedure, pass(x) :: new_comid => d_base_mlv_new_comid + procedure, pass(x) :: free_comid => d_base_mlv_free_comid + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! procedure, pass(x) :: gthab => d_base_mlv_gthab procedure, pass(x) :: gthzv => d_base_mlv_gthzv procedure, pass(x) :: gthzv_x => d_base_mlv_gthzv_x - generic, public :: gth => gthab, gthzv, gthzv_x + procedure, pass(x) :: gthzbuf => d_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf procedure, pass(y) :: sctb => d_base_mlv_sctb procedure, pass(y) :: sctb_x => d_base_mlv_sctb_x - generic, public :: sct => sctb, sctb_x + procedure, pass(y) :: sctb_buf => d_base_mlv_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf end type psb_d_base_multivect_type interface psb_d_base_multivect @@ -2421,6 +2436,57 @@ contains end subroutine d_base_mlv_absval2 + + function d_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function d_base_mlv_use_buffer + + subroutine d_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine d_base_mlv_new_buffer + + subroutine d_base_mlv_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2,x%comid,info) + end subroutine d_base_mlv_new_comid + + + subroutine d_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine d_base_mlv_free_buffer + + subroutine d_base_mlv_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_d_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine d_base_mlv_free_comid + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2495,6 +2561,27 @@ contains end subroutine d_base_mlv_gthzv + ! + ! New comm internals impl. + ! + subroutine d_base_mlv_gthzbuf(i,n,idx,x) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + class(psb_d_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) + + end subroutine d_base_mlv_gthzbuf + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2533,5 +2620,36 @@ contains end subroutine d_base_mlv_sctb_x + subroutine d_base_mlv_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + real(psb_dpk_) :: beta + class(psb_d_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) + call y%set_host() + + end subroutine d_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_d_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine d_base_mlv_device_wait() + implicit none + + end subroutine d_base_mlv_device_wait + end module psb_d_base_multivect_mod diff --git a/base/modules/psb_d_comm_mod.f90 b/base/modules/psb_d_comm_mod.f90 index 7dadc55f..55318168 100644 --- a/base/modules/psb_d_comm_mod.f90 +++ b/base/modules/psb_d_comm_mod.f90 @@ -32,8 +32,9 @@ module psb_d_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_ use psb_mat_mod, only : psb_dspmat_type - + use psb_d_vect_mod, only : psb_d_vect_type, psb_d_base_vect_type + use psb_d_multivect_mod, only : psb_d_multivect_type, psb_d_base_multivect_type interface psb_ovrl subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) @@ -96,6 +97,16 @@ module psb_d_comm_mod 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/psb_d_tools_mod.f90 b/base/modules/psb_d_tools_mod.f90 index e02f9533..42410bf4 100644 --- a/base/modules/psb_d_tools_mod.f90 +++ b/base/modules/psb_d_tools_mod.f90 @@ -33,6 +33,7 @@ Module psb_d_tools_mod use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type use psb_d_mat_mod, only : psb_dspmat_type, psb_d_base_sparse_mat + use psb_d_multivect_mod, only : psb_d_base_multivect_type, psb_d_multivect_type interface psb_geall subroutine psb_dalloc(x, desc_a, info, n, lb) @@ -67,6 +68,14 @@ Module psb_d_tools_mod integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), optional, intent(in) :: n, lb end subroutine psb_dalloc_vect_r2 + subroutine psb_dalloc_multivect(x, desc_a,info,n) + import + implicit none + type(psb_d_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_dalloc_multivect end interface @@ -103,6 +112,16 @@ Module psb_d_tools_mod class(psb_d_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch end subroutine psb_dasb_vect_r2 + subroutine psb_dasb_multivect(x, desc_a, info,mold, scratch, n) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_dasb_multivect end interface interface psb_gefree @@ -134,6 +153,13 @@ Module psb_d_tools_mod type(psb_d_vect_type), allocatable, intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_dfree_vect_r2 + subroutine psb_dfree_multivect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dfree_multivect end interface @@ -198,6 +224,18 @@ Module psb_d_tools_mod integer(psb_ipk_), optional, intent(in) :: dupl logical, intent(in), optional :: local end subroutine psb_dins_vect_r2 + subroutine psb_dins_multivect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_dins_multivect end interface interface psb_cdbldext diff --git a/base/modules/psb_d_vect_mod.F90 b/base/modules/psb_d_vect_mod.F90 index 4c1b5e6a..cbff8035 100644 --- a/base/modules/psb_d_vect_mod.F90 +++ b/base/modules/psb_d_vect_mod.F90 @@ -129,50 +129,50 @@ module psb_d_vect_mod interface psb_set_vect_default module procedure psb_d_set_vect_default - end interface + end interface psb_set_vect_default interface psb_get_vect_default module procedure psb_d_get_vect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_d_set_vect_default(v) implicit none class(psb_d_base_vect_type), intent(in) :: v - + if (allocated(psb_d_base_vect_default)) then deallocate(psb_d_base_vect_default) end if allocate(psb_d_base_vect_default, mold=v) end subroutine psb_d_set_vect_default - + function psb_d_get_vect_default(v) result(res) implicit none class(psb_d_vect_type), intent(in) :: v class(psb_d_base_vect_type), pointer :: res - + res => psb_d_get_base_vect_default() - + end function psb_d_get_vect_default - + function psb_d_get_base_vect_default() result(res) implicit none class(psb_d_base_vect_type), pointer :: res - + if (.not.allocated(psb_d_base_vect_default)) then allocate(psb_d_base_vect_type :: psb_d_base_vect_default) end if res => psb_d_base_vect_default - + end function psb_d_get_base_vect_default - + subroutine d_vect_clone(x,y,info) implicit none class(psb_d_vect_type), intent(inout) :: x @@ -185,7 +185,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine d_vect_clone - + subroutine d_vect_bld_x(x,invect,mold) real(psb_dpk_), intent(in) :: invect(:) class(psb_d_vect_type), intent(inout) :: x @@ -259,20 +259,20 @@ contains class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine d_vect_set_scal subroutine d_vect_set_vect(x,val,first,last) class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine d_vect_set_vect @@ -327,7 +327,7 @@ contains class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v)) & & call x%free(info) @@ -354,7 +354,7 @@ contains integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) @@ -382,7 +382,7 @@ contains if (allocated(x%v)) & & call x%v%asb(n,info) - + end subroutine d_vect_asb subroutine d_vect_gthab(n,idx,alpha,x,beta,y) @@ -390,10 +390,10 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: alpha, beta, y(:) class(psb_d_vect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine d_vect_gthab subroutine d_vect_gthzv(n,idx,x,y) @@ -404,7 +404,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine d_vect_gthzv subroutine d_vect_sctb(n,idx,x,beta,y) @@ -412,7 +412,7 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:) class(psb_d_vect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -424,13 +424,13 @@ contains implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine d_vect_free subroutine d_vect_ins_a(n,irl,val,dupl,x,info) @@ -449,9 +449,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine d_vect_ins_a subroutine d_vect_ins_v(n,irl,val,dupl,x,info) @@ -501,73 +501,73 @@ contains subroutine d_vect_sync(x) implicit none class(psb_d_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine d_vect_sync subroutine d_vect_set_sync(x) implicit none class(psb_d_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_sync() - + end subroutine d_vect_set_sync subroutine d_vect_set_host(x) implicit none class(psb_d_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_host() - + end subroutine d_vect_set_host subroutine d_vect_set_dev(x) implicit none class(psb_d_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_dev() - + end subroutine d_vect_set_dev function d_vect_is_sync(x) result(res) implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_sync() - + end function d_vect_is_sync function d_vect_is_host(x) result(res) implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_host() - + end function d_vect_is_host function d_vect_is_dev(x) result(res) implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x - + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() - + end function d_vect_is_dev - + function d_vect_dot_v(n,x,y) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x, y @@ -586,13 +586,13 @@ contains real(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + res = dzero if (allocated(x%v)) & & res = x%v%dot(n,y) - + end function d_vect_dot_a - + subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod implicit none @@ -601,7 +601,7 @@ contains class(psb_d_vect_type), intent(inout) :: y real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else @@ -618,13 +618,13 @@ contains class(psb_d_vect_type), intent(inout) :: y real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(y%v)) & & call y%v%axpby(m,alpha,x,beta,info) - + end subroutine d_vect_axpby_a - + subroutine d_vect_mlt_v(x, y, info) use psi_serial_mod implicit none @@ -651,7 +651,7 @@ contains info = 0 if (allocated(y%v)) & & call y%v%mlt(x,info) - + end subroutine d_vect_mlt_a @@ -668,7 +668,7 @@ contains info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) - + end subroutine d_vect_mlt_a_2 subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) @@ -717,7 +717,7 @@ contains integer(psb_ipk_) :: i, n info = 0 - + if (allocated(z%v).and.allocated(x%v)) & & call z%v%mlt(alpha,x%v,y,beta,info) @@ -728,14 +728,14 @@ contains implicit none class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha - + if (allocated(x%v)) call x%v%scal(alpha) end subroutine d_vect_scal subroutine d_vect_absval1(x) class(psb_d_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%absval() @@ -744,19 +744,19 @@ contains subroutine d_vect_absval2(x,y) class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y - + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(size(x%v%v)) call x%v%absval(y%v) end if end subroutine d_vect_absval2 - + function d_vect_nrm2(n,x) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (allocated(x%v)) then res = x%v%nrm2(n) else @@ -764,7 +764,7 @@ contains end if end function d_vect_nrm2 - + function d_vect_amax(n,x) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x @@ -792,7 +792,7 @@ contains end if end function d_vect_asum - + end module psb_d_vect_mod @@ -859,62 +859,63 @@ module psb_d_multivect_mod end type psb_d_multivect_type public :: psb_d_multivect, psb_d_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_d_base_multivect_type private interface psb_d_multivect module procedure constructor, size_const - end interface - + end interface psb_d_multivect + class(psb_d_base_multivect_type), allocatable, target,& & save, private :: psb_d_base_multivect_default interface psb_set_multivect_default module procedure psb_d_set_multivect_default - end interface + end interface psb_set_multivect_default interface psb_get_vect_default module procedure psb_d_get_multivect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_d_set_multivect_default(v) implicit none class(psb_d_base_multivect_type), intent(in) :: v - + if (allocated(psb_d_base_multivect_default)) then deallocate(psb_d_base_multivect_default) end if allocate(psb_d_base_multivect_default, mold=v) end subroutine psb_d_set_multivect_default - + function psb_d_get_multivect_default(v) result(res) implicit none class(psb_d_multivect_type), intent(in) :: v class(psb_d_base_multivect_type), pointer :: res - + res => psb_d_get_base_multivect_default() - + end function psb_d_get_multivect_default - + function psb_d_get_base_multivect_default() result(res) implicit none class(psb_d_base_multivect_type), pointer :: res - + if (.not.allocated(psb_d_base_multivect_default)) then allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default) end if res => psb_d_base_multivect_default - + end function psb_d_get_base_multivect_default - + subroutine d_vect_clone(x,y,info) implicit none class(psb_d_multivect_type), intent(inout) :: x @@ -927,7 +928,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine d_vect_clone - + subroutine d_vect_bld_x(x,invect,mold) real(psb_dpk_), intent(in) :: invect(:,:) class(psb_d_multivect_type), intent(out) :: x @@ -993,19 +994,19 @@ contains subroutine d_vect_set_scal(x,val) class(psb_d_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine d_vect_set_scal subroutine d_vect_set_vect(x,val) class(psb_d_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val(:,:) - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine d_vect_set_vect @@ -1061,7 +1062,7 @@ contains res = 'NULL' if (allocated(x%v)) res = x%v%get_fmt() end function d_vect_get_fmt - + subroutine d_vect_all(m,n, x, info, mold) implicit none @@ -1069,7 +1070,7 @@ contains class(psb_d_multivect_type), intent(out) :: x class(psb_d_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (present(mold)) then #ifdef HAVE_MOLD allocate(x%v,stat=info,mold=mold) @@ -1093,7 +1094,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) @@ -1121,16 +1122,16 @@ contains if (allocated(x%v)) & & call x%v%asb(m,n,info) - + end subroutine d_vect_asb subroutine d_vect_sync(x) implicit none class(psb_d_multivect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine d_vect_sync subroutine d_vect_gthab(n,idx,alpha,x,beta,y) @@ -1138,10 +1139,10 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: alpha, beta, y(:) class(psb_d_multivect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine d_vect_gthab subroutine d_vect_gthzv(n,idx,x,y) @@ -1152,7 +1153,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine d_vect_gthzv subroutine d_vect_gthzv_x(i,n,idx,x,y) @@ -1164,7 +1165,7 @@ contains if (allocated(x%v)) & & call x%v%gth(i,n,idx,y) - + end subroutine d_vect_gthzv_x subroutine d_vect_sctb(n,idx,x,beta,y) @@ -1172,7 +1173,7 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:) class(psb_d_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -1184,7 +1185,7 @@ contains class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: beta, x(:) class(psb_d_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(i,n,idx,x,beta) @@ -1196,13 +1197,13 @@ contains implicit none class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine d_vect_free subroutine d_vect_ins(n,irl,val,dupl,x,info) @@ -1221,9 +1222,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine d_vect_ins @@ -1248,7 +1249,7 @@ contains end if end subroutine d_vect_cnv - + !!$ function d_vect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x, y diff --git a/base/modules/psb_i_base_vect_mod.f90 b/base/modules/psb_i_base_vect_mod.f90 index 6d417d1b..5a90ace7 100644 --- a/base/modules/psb_i_base_vect_mod.f90 +++ b/base/modules/psb_i_base_vect_mod.f90 @@ -849,7 +849,6 @@ contains end subroutine i_base_sctb_x - subroutine i_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n @@ -898,6 +897,8 @@ module psb_i_base_multivect_mod type psb_i_base_multivect_type !> Values. integer(psb_ipk_), allocatable :: v(:,:) + integer(psb_ipk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -946,17 +947,31 @@ module psb_i_base_multivect_mod procedure, pass(x) :: set_vect => i_base_mlv_set_vect generic, public :: set => set_vect, set_scal -!!$ ! -!!$ ! Gather/scatter. These are needed for MPI interfacing. -!!$ ! May have to be reworked. -!!$ ! + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => i_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => i_base_mlv_new_buffer + procedure, nopass :: device_wait => i_base_mlv_device_wait + procedure, pass(x) :: free_buffer => i_base_mlv_free_buffer + procedure, pass(x) :: new_comid => i_base_mlv_new_comid + procedure, pass(x) :: free_comid => i_base_mlv_free_comid + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! procedure, pass(x) :: gthab => i_base_mlv_gthab procedure, pass(x) :: gthzv => i_base_mlv_gthzv procedure, pass(x) :: gthzv_x => i_base_mlv_gthzv_x - generic, public :: gth => gthab, gthzv, gthzv_x + procedure, pass(x) :: gthzbuf => i_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf procedure, pass(y) :: sctb => i_base_mlv_sctb procedure, pass(y) :: sctb_x => i_base_mlv_sctb_x - generic, public :: sct => sctb, sctb_x + procedure, pass(y) :: sctb_buf => i_base_mlv_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf end type psb_i_base_multivect_type interface psb_i_base_multivect @@ -1450,6 +1465,57 @@ contains end subroutine i_base_mlv_set_vect + + function i_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function i_base_mlv_use_buffer + + subroutine i_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine i_base_mlv_new_buffer + + subroutine i_base_mlv_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2,x%comid,info) + end subroutine i_base_mlv_new_comid + + + subroutine i_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine i_base_mlv_free_buffer + + subroutine i_base_mlv_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_i_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine i_base_mlv_free_comid + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1524,6 +1590,27 @@ contains end subroutine i_base_mlv_gthzv + ! + ! New comm internals impl. + ! + subroutine i_base_mlv_gthzbuf(i,n,idx,x) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) + + end subroutine i_base_mlv_gthzbuf + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -1562,5 +1649,36 @@ contains end subroutine i_base_mlv_sctb_x + subroutine i_base_mlv_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer(psb_ipk_) :: beta + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) + call y%set_host() + + end subroutine i_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_i_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine i_base_mlv_device_wait() + implicit none + + end subroutine i_base_mlv_device_wait + end module psb_i_base_multivect_mod diff --git a/base/modules/psb_i_comm_mod.f90 b/base/modules/psb_i_comm_mod.f90 index bdbbe3c6..e73424a3 100644 --- a/base/modules/psb_i_comm_mod.f90 +++ b/base/modules/psb_i_comm_mod.f90 @@ -31,8 +31,9 @@ !!$ module psb_i_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_ - + use psb_i_vect_mod, only : psb_i_vect_type, psb_i_base_vect_type + use psb_i_multivect_mod, only : psb_i_multivect_type, psb_i_base_multivect_type interface psb_ovrl subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) @@ -95,6 +96,16 @@ module psb_i_comm_mod integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran end subroutine psb_ihalo_vect + subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) + import + implicit none + type(psb_i_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_ihalo_multivect end interface psb_halo diff --git a/base/modules/psb_i_tools_mod.f90 b/base/modules/psb_i_tools_mod.f90 index d85dfa28..75fac022 100644 --- a/base/modules/psb_i_tools_mod.f90 +++ b/base/modules/psb_i_tools_mod.f90 @@ -32,6 +32,7 @@ Module psb_i_tools_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_success_ use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type + use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type interface psb_geall subroutine psb_ialloc(x, desc_a, info, n, lb) @@ -66,6 +67,14 @@ Module psb_i_tools_mod integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), optional, intent(in) :: n, lb end subroutine psb_ialloc_vect_r2 + subroutine psb_ialloc_multivect(x, desc_a,info,n) + import + implicit none + type(psb_i_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_ialloc_multivect end interface @@ -102,6 +111,16 @@ Module psb_i_tools_mod class(psb_i_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch end subroutine psb_iasb_vect_r2 + subroutine psb_iasb_multivect(x, desc_a, info,mold, scratch, n) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_iasb_multivect end interface interface psb_gefree @@ -133,6 +152,13 @@ Module psb_i_tools_mod type(psb_i_vect_type), allocatable, intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ifree_vect_r2 + subroutine psb_ifree_multivect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ifree_multivect end interface @@ -197,6 +223,18 @@ Module psb_i_tools_mod integer(psb_ipk_), optional, intent(in) :: dupl logical, intent(in), optional :: local end subroutine psb_iins_vect_r2 + subroutine psb_iins_multivect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_ipk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_iins_multivect end interface diff --git a/base/modules/psb_i_vect_mod.F90 b/base/modules/psb_i_vect_mod.F90 index 4b5c2188..4d39de77 100644 --- a/base/modules/psb_i_vect_mod.F90 +++ b/base/modules/psb_i_vect_mod.F90 @@ -102,50 +102,50 @@ module psb_i_vect_mod interface psb_set_vect_default module procedure psb_i_set_vect_default - end interface + end interface psb_set_vect_default interface psb_get_vect_default module procedure psb_i_get_vect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_i_set_vect_default(v) implicit none class(psb_i_base_vect_type), intent(in) :: v - + if (allocated(psb_i_base_vect_default)) then deallocate(psb_i_base_vect_default) end if allocate(psb_i_base_vect_default, mold=v) end subroutine psb_i_set_vect_default - + function psb_i_get_vect_default(v) result(res) implicit none class(psb_i_vect_type), intent(in) :: v class(psb_i_base_vect_type), pointer :: res - + res => psb_i_get_base_vect_default() - + end function psb_i_get_vect_default - + function psb_i_get_base_vect_default() result(res) implicit none class(psb_i_base_vect_type), pointer :: res - + if (.not.allocated(psb_i_base_vect_default)) then allocate(psb_i_base_vect_type :: psb_i_base_vect_default) end if res => psb_i_base_vect_default - + end function psb_i_get_base_vect_default - + subroutine i_vect_clone(x,y,info) implicit none class(psb_i_vect_type), intent(inout) :: x @@ -158,7 +158,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine i_vect_clone - + subroutine i_vect_bld_x(x,invect,mold) integer(psb_ipk_), intent(in) :: invect(:) class(psb_i_vect_type), intent(inout) :: x @@ -232,20 +232,20 @@ contains class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine i_vect_set_scal subroutine i_vect_set_vect(x,val,first,last) class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine i_vect_set_vect @@ -300,7 +300,7 @@ contains class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v)) & & call x%free(info) @@ -327,7 +327,7 @@ contains integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) @@ -355,7 +355,7 @@ contains if (allocated(x%v)) & & call x%v%asb(n,info) - + end subroutine i_vect_asb subroutine i_vect_gthab(n,idx,alpha,x,beta,y) @@ -363,10 +363,10 @@ contains integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: alpha, beta, y(:) class(psb_i_vect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine i_vect_gthab subroutine i_vect_gthzv(n,idx,x,y) @@ -377,7 +377,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine i_vect_gthzv subroutine i_vect_sctb(n,idx,x,beta,y) @@ -385,7 +385,7 @@ contains integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:) class(psb_i_vect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -397,13 +397,13 @@ contains implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine i_vect_free subroutine i_vect_ins_a(n,irl,val,dupl,x,info) @@ -422,9 +422,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine i_vect_ins_a subroutine i_vect_ins_v(n,irl,val,dupl,x,info) @@ -474,70 +474,70 @@ contains subroutine i_vect_sync(x) implicit none class(psb_i_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine i_vect_sync subroutine i_vect_set_sync(x) implicit none class(psb_i_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_sync() - + end subroutine i_vect_set_sync subroutine i_vect_set_host(x) implicit none class(psb_i_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_host() - + end subroutine i_vect_set_host subroutine i_vect_set_dev(x) implicit none class(psb_i_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_dev() - + end subroutine i_vect_set_dev function i_vect_is_sync(x) result(res) implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_sync() - + end function i_vect_is_sync function i_vect_is_host(x) result(res) implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_host() - + end function i_vect_is_host function i_vect_is_dev(x) result(res) implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x - + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() - + end function i_vect_is_dev @@ -588,62 +588,63 @@ module psb_i_multivect_mod end type psb_i_multivect_type public :: psb_i_multivect, psb_i_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_i_base_multivect_type private interface psb_i_multivect module procedure constructor, size_const - end interface - + end interface psb_i_multivect + class(psb_i_base_multivect_type), allocatable, target,& & save, private :: psb_i_base_multivect_default interface psb_set_multivect_default module procedure psb_i_set_multivect_default - end interface + end interface psb_set_multivect_default interface psb_get_vect_default module procedure psb_i_get_multivect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_i_set_multivect_default(v) implicit none class(psb_i_base_multivect_type), intent(in) :: v - + if (allocated(psb_i_base_multivect_default)) then deallocate(psb_i_base_multivect_default) end if allocate(psb_i_base_multivect_default, mold=v) end subroutine psb_i_set_multivect_default - + function psb_i_get_multivect_default(v) result(res) implicit none class(psb_i_multivect_type), intent(in) :: v class(psb_i_base_multivect_type), pointer :: res - + res => psb_i_get_base_multivect_default() - + end function psb_i_get_multivect_default - + function psb_i_get_base_multivect_default() result(res) implicit none class(psb_i_base_multivect_type), pointer :: res - + if (.not.allocated(psb_i_base_multivect_default)) then allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default) end if res => psb_i_base_multivect_default - + end function psb_i_get_base_multivect_default - + subroutine i_vect_clone(x,y,info) implicit none class(psb_i_multivect_type), intent(inout) :: x @@ -656,7 +657,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine i_vect_clone - + subroutine i_vect_bld_x(x,invect,mold) integer(psb_ipk_), intent(in) :: invect(:,:) class(psb_i_multivect_type), intent(out) :: x @@ -722,19 +723,19 @@ contains subroutine i_vect_set_scal(x,val) class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine i_vect_set_scal subroutine i_vect_set_vect(x,val) class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val(:,:) - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine i_vect_set_vect @@ -790,7 +791,7 @@ contains res = 'NULL' if (allocated(x%v)) res = x%v%get_fmt() end function i_vect_get_fmt - + subroutine i_vect_all(m,n, x, info, mold) implicit none @@ -798,7 +799,7 @@ contains class(psb_i_multivect_type), intent(out) :: x class(psb_i_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (present(mold)) then #ifdef HAVE_MOLD allocate(x%v,stat=info,mold=mold) @@ -822,7 +823,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) @@ -850,16 +851,16 @@ contains if (allocated(x%v)) & & call x%v%asb(m,n,info) - + end subroutine i_vect_asb subroutine i_vect_sync(x) implicit none class(psb_i_multivect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine i_vect_sync subroutine i_vect_gthab(n,idx,alpha,x,beta,y) @@ -867,10 +868,10 @@ contains integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: alpha, beta, y(:) class(psb_i_multivect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine i_vect_gthab subroutine i_vect_gthzv(n,idx,x,y) @@ -881,7 +882,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine i_vect_gthzv subroutine i_vect_gthzv_x(i,n,idx,x,y) @@ -893,7 +894,7 @@ contains if (allocated(x%v)) & & call x%v%gth(i,n,idx,y) - + end subroutine i_vect_gthzv_x subroutine i_vect_sctb(n,idx,x,beta,y) @@ -901,7 +902,7 @@ contains integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:) class(psb_i_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -913,7 +914,7 @@ contains class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: beta, x(:) class(psb_i_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(i,n,idx,x,beta) @@ -925,13 +926,13 @@ contains implicit none class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine i_vect_free subroutine i_vect_ins(n,irl,val,dupl,x,info) @@ -950,9 +951,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine i_vect_ins diff --git a/base/modules/psb_s_base_vect_mod.f90 b/base/modules/psb_s_base_vect_mod.f90 index 3e361aac..cb08261a 100644 --- a/base/modules/psb_s_base_vect_mod.f90 +++ b/base/modules/psb_s_base_vect_mod.f90 @@ -1308,7 +1308,6 @@ contains end subroutine s_base_sctb_x - subroutine s_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n @@ -1357,6 +1356,8 @@ module psb_s_base_multivect_mod type psb_s_base_multivect_type !> Values. real(psb_spk_), allocatable :: v(:,:) + real(psb_spk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1438,17 +1439,31 @@ module psb_s_base_multivect_mod procedure, pass(x) :: absval1 => s_base_mlv_absval1 procedure, pass(x) :: absval2 => s_base_mlv_absval2 generic, public :: absval => absval1, absval2 -!!$ ! -!!$ ! Gather/scatter. These are needed for MPI interfacing. -!!$ ! May have to be reworked. -!!$ ! + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => s_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => s_base_mlv_new_buffer + procedure, nopass :: device_wait => s_base_mlv_device_wait + procedure, pass(x) :: free_buffer => s_base_mlv_free_buffer + procedure, pass(x) :: new_comid => s_base_mlv_new_comid + procedure, pass(x) :: free_comid => s_base_mlv_free_comid + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! procedure, pass(x) :: gthab => s_base_mlv_gthab procedure, pass(x) :: gthzv => s_base_mlv_gthzv procedure, pass(x) :: gthzv_x => s_base_mlv_gthzv_x - generic, public :: gth => gthab, gthzv, gthzv_x + procedure, pass(x) :: gthzbuf => s_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf procedure, pass(y) :: sctb => s_base_mlv_sctb procedure, pass(y) :: sctb_x => s_base_mlv_sctb_x - generic, public :: sct => sctb, sctb_x + procedure, pass(y) :: sctb_buf => s_base_mlv_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf end type psb_s_base_multivect_type interface psb_s_base_multivect @@ -2421,6 +2436,57 @@ contains end subroutine s_base_mlv_absval2 + + function s_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function s_base_mlv_use_buffer + + subroutine s_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine s_base_mlv_new_buffer + + subroutine s_base_mlv_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2,x%comid,info) + end subroutine s_base_mlv_new_comid + + + subroutine s_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine s_base_mlv_free_buffer + + subroutine s_base_mlv_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_s_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine s_base_mlv_free_comid + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2495,6 +2561,27 @@ contains end subroutine s_base_mlv_gthzv + ! + ! New comm internals impl. + ! + subroutine s_base_mlv_gthzbuf(i,n,idx,x) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + class(psb_s_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) + + end subroutine s_base_mlv_gthzbuf + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2533,5 +2620,36 @@ contains end subroutine s_base_mlv_sctb_x + subroutine s_base_mlv_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + real(psb_spk_) :: beta + class(psb_s_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) + call y%set_host() + + end subroutine s_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_s_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine s_base_mlv_device_wait() + implicit none + + end subroutine s_base_mlv_device_wait + end module psb_s_base_multivect_mod diff --git a/base/modules/psb_s_comm_mod.f90 b/base/modules/psb_s_comm_mod.f90 index a0fba209..cf16e3ba 100644 --- a/base/modules/psb_s_comm_mod.f90 +++ b/base/modules/psb_s_comm_mod.f90 @@ -32,8 +32,9 @@ module psb_s_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_ use psb_mat_mod, only : psb_sspmat_type - + use psb_s_vect_mod, only : psb_s_vect_type, psb_s_base_vect_type + use psb_s_multivect_mod, only : psb_s_multivect_type, psb_s_base_multivect_type interface psb_ovrl subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) @@ -96,6 +97,16 @@ module psb_s_comm_mod integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran end subroutine psb_shalo_vect + subroutine psb_shalo_multivect(x,desc_a,info,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 + 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 end interface psb_halo diff --git a/base/modules/psb_s_tools_mod.f90 b/base/modules/psb_s_tools_mod.f90 index 6710fd61..b4e0b2f6 100644 --- a/base/modules/psb_s_tools_mod.f90 +++ b/base/modules/psb_s_tools_mod.f90 @@ -33,6 +33,7 @@ Module psb_s_tools_mod use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_ use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type, psb_i_vect_type use psb_s_mat_mod, only : psb_sspmat_type, psb_s_base_sparse_mat + use psb_s_multivect_mod, only : psb_s_base_multivect_type, psb_s_multivect_type interface psb_geall subroutine psb_salloc(x, desc_a, info, n, lb) @@ -67,6 +68,14 @@ Module psb_s_tools_mod integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), optional, intent(in) :: n, lb end subroutine psb_salloc_vect_r2 + subroutine psb_salloc_multivect(x, desc_a,info,n) + import + implicit none + type(psb_s_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_salloc_multivect end interface @@ -103,6 +112,16 @@ Module psb_s_tools_mod class(psb_s_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch end subroutine psb_sasb_vect_r2 + subroutine psb_sasb_multivect(x, desc_a, info,mold, scratch, n) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_sasb_multivect end interface interface psb_gefree @@ -134,6 +153,13 @@ Module psb_s_tools_mod type(psb_s_vect_type), allocatable, intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_sfree_vect_r2 + subroutine psb_sfree_multivect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sfree_multivect end interface @@ -198,6 +224,18 @@ Module psb_s_tools_mod integer(psb_ipk_), optional, intent(in) :: dupl logical, intent(in), optional :: local end subroutine psb_sins_vect_r2 + subroutine psb_sins_multivect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_sins_multivect end interface interface psb_cdbldext diff --git a/base/modules/psb_s_vect_mod.F90 b/base/modules/psb_s_vect_mod.F90 index b5fa25e4..2bb284cb 100644 --- a/base/modules/psb_s_vect_mod.F90 +++ b/base/modules/psb_s_vect_mod.F90 @@ -129,50 +129,50 @@ module psb_s_vect_mod interface psb_set_vect_default module procedure psb_s_set_vect_default - end interface + end interface psb_set_vect_default interface psb_get_vect_default module procedure psb_s_get_vect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_s_set_vect_default(v) implicit none class(psb_s_base_vect_type), intent(in) :: v - + if (allocated(psb_s_base_vect_default)) then deallocate(psb_s_base_vect_default) end if allocate(psb_s_base_vect_default, mold=v) end subroutine psb_s_set_vect_default - + function psb_s_get_vect_default(v) result(res) implicit none class(psb_s_vect_type), intent(in) :: v class(psb_s_base_vect_type), pointer :: res - + res => psb_s_get_base_vect_default() - + end function psb_s_get_vect_default - + function psb_s_get_base_vect_default() result(res) implicit none class(psb_s_base_vect_type), pointer :: res - + if (.not.allocated(psb_s_base_vect_default)) then allocate(psb_s_base_vect_type :: psb_s_base_vect_default) end if res => psb_s_base_vect_default - + end function psb_s_get_base_vect_default - + subroutine s_vect_clone(x,y,info) implicit none class(psb_s_vect_type), intent(inout) :: x @@ -185,7 +185,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine s_vect_clone - + subroutine s_vect_bld_x(x,invect,mold) real(psb_spk_), intent(in) :: invect(:) class(psb_s_vect_type), intent(inout) :: x @@ -259,20 +259,20 @@ contains class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine s_vect_set_scal subroutine s_vect_set_vect(x,val,first,last) class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine s_vect_set_vect @@ -327,7 +327,7 @@ contains class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v)) & & call x%free(info) @@ -354,7 +354,7 @@ contains integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) @@ -382,7 +382,7 @@ contains if (allocated(x%v)) & & call x%v%asb(n,info) - + end subroutine s_vect_asb subroutine s_vect_gthab(n,idx,alpha,x,beta,y) @@ -390,10 +390,10 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: alpha, beta, y(:) class(psb_s_vect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine s_vect_gthab subroutine s_vect_gthzv(n,idx,x,y) @@ -404,7 +404,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine s_vect_gthzv subroutine s_vect_sctb(n,idx,x,beta,y) @@ -412,7 +412,7 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:) class(psb_s_vect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -424,13 +424,13 @@ contains implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine s_vect_free subroutine s_vect_ins_a(n,irl,val,dupl,x,info) @@ -449,9 +449,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine s_vect_ins_a subroutine s_vect_ins_v(n,irl,val,dupl,x,info) @@ -501,73 +501,73 @@ contains subroutine s_vect_sync(x) implicit none class(psb_s_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine s_vect_sync subroutine s_vect_set_sync(x) implicit none class(psb_s_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_sync() - + end subroutine s_vect_set_sync subroutine s_vect_set_host(x) implicit none class(psb_s_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_host() - + end subroutine s_vect_set_host subroutine s_vect_set_dev(x) implicit none class(psb_s_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_dev() - + end subroutine s_vect_set_dev function s_vect_is_sync(x) result(res) implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_sync() - + end function s_vect_is_sync function s_vect_is_host(x) result(res) implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_host() - + end function s_vect_is_host function s_vect_is_dev(x) result(res) implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x - + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() - + end function s_vect_is_dev - + function s_vect_dot_v(n,x,y) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x, y @@ -586,13 +586,13 @@ contains real(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + res = szero if (allocated(x%v)) & & res = x%v%dot(n,y) - + end function s_vect_dot_a - + subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod implicit none @@ -601,7 +601,7 @@ contains class(psb_s_vect_type), intent(inout) :: y real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else @@ -618,13 +618,13 @@ contains class(psb_s_vect_type), intent(inout) :: y real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(y%v)) & & call y%v%axpby(m,alpha,x,beta,info) - + end subroutine s_vect_axpby_a - + subroutine s_vect_mlt_v(x, y, info) use psi_serial_mod implicit none @@ -651,7 +651,7 @@ contains info = 0 if (allocated(y%v)) & & call y%v%mlt(x,info) - + end subroutine s_vect_mlt_a @@ -668,7 +668,7 @@ contains info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) - + end subroutine s_vect_mlt_a_2 subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) @@ -717,7 +717,7 @@ contains integer(psb_ipk_) :: i, n info = 0 - + if (allocated(z%v).and.allocated(x%v)) & & call z%v%mlt(alpha,x%v,y,beta,info) @@ -728,14 +728,14 @@ contains implicit none class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha - + if (allocated(x%v)) call x%v%scal(alpha) end subroutine s_vect_scal subroutine s_vect_absval1(x) class(psb_s_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%absval() @@ -744,19 +744,19 @@ contains subroutine s_vect_absval2(x,y) class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y - + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(size(x%v%v)) call x%v%absval(y%v) end if end subroutine s_vect_absval2 - + function s_vect_nrm2(n,x) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (allocated(x%v)) then res = x%v%nrm2(n) else @@ -764,7 +764,7 @@ contains end if end function s_vect_nrm2 - + function s_vect_amax(n,x) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x @@ -792,7 +792,7 @@ contains end if end function s_vect_asum - + end module psb_s_vect_mod @@ -859,62 +859,63 @@ module psb_s_multivect_mod end type psb_s_multivect_type public :: psb_s_multivect, psb_s_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_s_base_multivect_type private interface psb_s_multivect module procedure constructor, size_const - end interface - + end interface psb_s_multivect + class(psb_s_base_multivect_type), allocatable, target,& & save, private :: psb_s_base_multivect_default interface psb_set_multivect_default module procedure psb_s_set_multivect_default - end interface + end interface psb_set_multivect_default interface psb_get_vect_default module procedure psb_s_get_multivect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_s_set_multivect_default(v) implicit none class(psb_s_base_multivect_type), intent(in) :: v - + if (allocated(psb_s_base_multivect_default)) then deallocate(psb_s_base_multivect_default) end if allocate(psb_s_base_multivect_default, mold=v) end subroutine psb_s_set_multivect_default - + function psb_s_get_multivect_default(v) result(res) implicit none class(psb_s_multivect_type), intent(in) :: v class(psb_s_base_multivect_type), pointer :: res - + res => psb_s_get_base_multivect_default() - + end function psb_s_get_multivect_default - + function psb_s_get_base_multivect_default() result(res) implicit none class(psb_s_base_multivect_type), pointer :: res - + if (.not.allocated(psb_s_base_multivect_default)) then allocate(psb_s_base_multivect_type :: psb_s_base_multivect_default) end if res => psb_s_base_multivect_default - + end function psb_s_get_base_multivect_default - + subroutine s_vect_clone(x,y,info) implicit none class(psb_s_multivect_type), intent(inout) :: x @@ -927,7 +928,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine s_vect_clone - + subroutine s_vect_bld_x(x,invect,mold) real(psb_spk_), intent(in) :: invect(:,:) class(psb_s_multivect_type), intent(out) :: x @@ -993,19 +994,19 @@ contains subroutine s_vect_set_scal(x,val) class(psb_s_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine s_vect_set_scal subroutine s_vect_set_vect(x,val) class(psb_s_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val(:,:) - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine s_vect_set_vect @@ -1061,7 +1062,7 @@ contains res = 'NULL' if (allocated(x%v)) res = x%v%get_fmt() end function s_vect_get_fmt - + subroutine s_vect_all(m,n, x, info, mold) implicit none @@ -1069,7 +1070,7 @@ contains class(psb_s_multivect_type), intent(out) :: x class(psb_s_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (present(mold)) then #ifdef HAVE_MOLD allocate(x%v,stat=info,mold=mold) @@ -1093,7 +1094,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) @@ -1121,16 +1122,16 @@ contains if (allocated(x%v)) & & call x%v%asb(m,n,info) - + end subroutine s_vect_asb subroutine s_vect_sync(x) implicit none class(psb_s_multivect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine s_vect_sync subroutine s_vect_gthab(n,idx,alpha,x,beta,y) @@ -1138,10 +1139,10 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: alpha, beta, y(:) class(psb_s_multivect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine s_vect_gthab subroutine s_vect_gthzv(n,idx,x,y) @@ -1152,7 +1153,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine s_vect_gthzv subroutine s_vect_gthzv_x(i,n,idx,x,y) @@ -1164,7 +1165,7 @@ contains if (allocated(x%v)) & & call x%v%gth(i,n,idx,y) - + end subroutine s_vect_gthzv_x subroutine s_vect_sctb(n,idx,x,beta,y) @@ -1172,7 +1173,7 @@ contains integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:) class(psb_s_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -1184,7 +1185,7 @@ contains class(psb_i_base_vect_type) :: idx real(psb_spk_) :: beta, x(:) class(psb_s_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(i,n,idx,x,beta) @@ -1196,13 +1197,13 @@ contains implicit none class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine s_vect_free subroutine s_vect_ins(n,irl,val,dupl,x,info) @@ -1221,9 +1222,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine s_vect_ins @@ -1248,7 +1249,7 @@ contains end if end subroutine s_vect_cnv - + !!$ function s_vect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x, y diff --git a/base/modules/psb_z_base_vect_mod.f90 b/base/modules/psb_z_base_vect_mod.f90 index 3179c619..0c028a51 100644 --- a/base/modules/psb_z_base_vect_mod.f90 +++ b/base/modules/psb_z_base_vect_mod.f90 @@ -1308,7 +1308,6 @@ contains end subroutine z_base_sctb_x - subroutine z_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n @@ -1357,6 +1356,8 @@ module psb_z_base_multivect_mod type psb_z_base_multivect_type !> Values. complex(psb_dpk_), allocatable :: v(:,:) + complex(psb_dpk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1438,17 +1439,31 @@ module psb_z_base_multivect_mod procedure, pass(x) :: absval1 => z_base_mlv_absval1 procedure, pass(x) :: absval2 => z_base_mlv_absval2 generic, public :: absval => absval1, absval2 -!!$ ! -!!$ ! Gather/scatter. These are needed for MPI interfacing. -!!$ ! May have to be reworked. -!!$ ! + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => z_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => z_base_mlv_new_buffer + procedure, nopass :: device_wait => z_base_mlv_device_wait + procedure, pass(x) :: free_buffer => z_base_mlv_free_buffer + procedure, pass(x) :: new_comid => z_base_mlv_new_comid + procedure, pass(x) :: free_comid => z_base_mlv_free_comid + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! procedure, pass(x) :: gthab => z_base_mlv_gthab procedure, pass(x) :: gthzv => z_base_mlv_gthzv procedure, pass(x) :: gthzv_x => z_base_mlv_gthzv_x - generic, public :: gth => gthab, gthzv, gthzv_x + procedure, pass(x) :: gthzbuf => z_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf procedure, pass(y) :: sctb => z_base_mlv_sctb procedure, pass(y) :: sctb_x => z_base_mlv_sctb_x - generic, public :: sct => sctb, sctb_x + procedure, pass(y) :: sctb_buf => z_base_mlv_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf end type psb_z_base_multivect_type interface psb_z_base_multivect @@ -2421,6 +2436,57 @@ contains end subroutine z_base_mlv_absval2 + + function z_base_mlv_use_buffer() result(res) + logical :: res + + res = .true. + end function z_base_mlv_use_buffer + + subroutine z_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine z_base_mlv_new_buffer + + subroutine z_base_mlv_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2,x%comid,info) + end subroutine z_base_mlv_new_comid + + + subroutine z_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine z_base_mlv_free_buffer + + subroutine z_base_mlv_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_z_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine z_base_mlv_free_comid + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -2495,6 +2561,27 @@ contains end subroutine z_base_mlv_gthzv + ! + ! New comm internals impl. + ! + subroutine z_base_mlv_gthzbuf(i,n,idx,x) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + class(psb_z_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf((i-1)*nc+1:)) + + end subroutine z_base_mlv_gthzbuf + ! ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) @@ -2533,5 +2620,36 @@ contains end subroutine z_base_mlv_sctb_x + subroutine z_base_mlv_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + complex(psb_dpk_) :: beta + class(psb_z_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf((i-1)*nc+1:),beta) + call y%set_host() + + end subroutine z_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_z_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine z_base_mlv_device_wait() + implicit none + + end subroutine z_base_mlv_device_wait + end module psb_z_base_multivect_mod diff --git a/base/modules/psb_z_comm_mod.f90 b/base/modules/psb_z_comm_mod.f90 index 8ecd98ef..ca0c1b5e 100644 --- a/base/modules/psb_z_comm_mod.f90 +++ b/base/modules/psb_z_comm_mod.f90 @@ -32,8 +32,9 @@ module psb_z_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_ use psb_mat_mod, only : psb_zspmat_type - + use psb_z_vect_mod, only : psb_z_vect_type, psb_z_base_vect_type + use psb_z_multivect_mod, only : psb_z_multivect_type, psb_z_base_multivect_type interface psb_ovrl subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) @@ -96,6 +97,16 @@ module psb_z_comm_mod integer(psb_ipk_), intent(in), optional :: mode,data character, intent(in), optional :: tran end subroutine psb_zhalo_vect + subroutine psb_zhalo_multivect(x,desc_a,info,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 + 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 end interface psb_halo diff --git a/base/modules/psb_z_tools_mod.f90 b/base/modules/psb_z_tools_mod.f90 index 3de0bd94..412296dd 100644 --- a/base/modules/psb_z_tools_mod.f90 +++ b/base/modules/psb_z_tools_mod.f90 @@ -33,6 +33,7 @@ Module psb_z_tools_mod use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type, psb_i_vect_type use psb_z_mat_mod, only : psb_zspmat_type, psb_z_base_sparse_mat + use psb_z_multivect_mod, only : psb_z_base_multivect_type, psb_z_multivect_type interface psb_geall subroutine psb_zalloc(x, desc_a, info, n, lb) @@ -67,6 +68,14 @@ Module psb_z_tools_mod integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), optional, intent(in) :: n, lb end subroutine psb_zalloc_vect_r2 + subroutine psb_zalloc_multivect(x, desc_a,info,n) + import + implicit none + type(psb_z_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_zalloc_multivect end interface @@ -103,6 +112,16 @@ Module psb_z_tools_mod class(psb_z_base_vect_type), intent(in), optional :: mold logical, intent(in), optional :: scratch end subroutine psb_zasb_vect_r2 + subroutine psb_zasb_multivect(x, desc_a, info,mold, scratch, n) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_zasb_multivect end interface interface psb_gefree @@ -134,6 +153,13 @@ Module psb_z_tools_mod type(psb_z_vect_type), allocatable, intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_zfree_vect_r2 + subroutine psb_zfree_multivect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zfree_multivect end interface @@ -198,6 +224,18 @@ Module psb_z_tools_mod integer(psb_ipk_), optional, intent(in) :: dupl logical, intent(in), optional :: local end subroutine psb_zins_vect_r2 + subroutine psb_zins_multivect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_zins_multivect end interface interface psb_cdbldext diff --git a/base/modules/psb_z_vect_mod.F90 b/base/modules/psb_z_vect_mod.F90 index 22ec9766..381c3a34 100644 --- a/base/modules/psb_z_vect_mod.F90 +++ b/base/modules/psb_z_vect_mod.F90 @@ -129,50 +129,50 @@ module psb_z_vect_mod interface psb_set_vect_default module procedure psb_z_set_vect_default - end interface + end interface psb_set_vect_default interface psb_get_vect_default module procedure psb_z_get_vect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_z_set_vect_default(v) implicit none class(psb_z_base_vect_type), intent(in) :: v - + if (allocated(psb_z_base_vect_default)) then deallocate(psb_z_base_vect_default) end if allocate(psb_z_base_vect_default, mold=v) end subroutine psb_z_set_vect_default - + function psb_z_get_vect_default(v) result(res) implicit none class(psb_z_vect_type), intent(in) :: v class(psb_z_base_vect_type), pointer :: res - + res => psb_z_get_base_vect_default() - + end function psb_z_get_vect_default - + function psb_z_get_base_vect_default() result(res) implicit none class(psb_z_base_vect_type), pointer :: res - + if (.not.allocated(psb_z_base_vect_default)) then allocate(psb_z_base_vect_type :: psb_z_base_vect_default) end if res => psb_z_base_vect_default - + end function psb_z_get_base_vect_default - + subroutine z_vect_clone(x,y,info) implicit none class(psb_z_vect_type), intent(inout) :: x @@ -185,7 +185,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine z_vect_clone - + subroutine z_vect_bld_x(x,invect,mold) complex(psb_dpk_), intent(in) :: invect(:) class(psb_z_vect_type), intent(inout) :: x @@ -259,20 +259,20 @@ contains class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine z_vect_set_scal subroutine z_vect_set_vect(x,val,first,last) class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val,first,last) - + end subroutine z_vect_set_vect @@ -327,7 +327,7 @@ contains class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v)) & & call x%free(info) @@ -354,7 +354,7 @@ contains integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) @@ -382,7 +382,7 @@ contains if (allocated(x%v)) & & call x%v%asb(n,info) - + end subroutine z_vect_asb subroutine z_vect_gthab(n,idx,alpha,x,beta,y) @@ -390,10 +390,10 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: alpha, beta, y(:) class(psb_z_vect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine z_vect_gthab subroutine z_vect_gthzv(n,idx,x,y) @@ -404,7 +404,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine z_vect_gthzv subroutine z_vect_sctb(n,idx,x,beta,y) @@ -412,7 +412,7 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:) class(psb_z_vect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -424,13 +424,13 @@ contains implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine z_vect_free subroutine z_vect_ins_a(n,irl,val,dupl,x,info) @@ -449,9 +449,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine z_vect_ins_a subroutine z_vect_ins_v(n,irl,val,dupl,x,info) @@ -501,73 +501,73 @@ contains subroutine z_vect_sync(x) implicit none class(psb_z_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine z_vect_sync subroutine z_vect_set_sync(x) implicit none class(psb_z_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_sync() - + end subroutine z_vect_set_sync subroutine z_vect_set_host(x) implicit none class(psb_z_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_host() - + end subroutine z_vect_set_host subroutine z_vect_set_dev(x) implicit none class(psb_z_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%set_dev() - + end subroutine z_vect_set_dev function z_vect_is_sync(x) result(res) implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_sync() - + end function z_vect_is_sync function z_vect_is_host(x) result(res) implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x - + res = .true. if (allocated(x%v)) & & res = x%v%is_host() - + end function z_vect_is_host function z_vect_is_dev(x) result(res) implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x - + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() - + end function z_vect_is_dev - + function z_vect_dot_v(n,x,y) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x, y @@ -586,13 +586,13 @@ contains complex(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n complex(psb_dpk_) :: res - + res = zzero if (allocated(x%v)) & & res = x%v%dot(n,y) - + end function z_vect_dot_a - + subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod implicit none @@ -601,7 +601,7 @@ contains class(psb_z_vect_type), intent(inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else @@ -618,13 +618,13 @@ contains class(psb_z_vect_type), intent(inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (allocated(y%v)) & & call y%v%axpby(m,alpha,x,beta,info) - + end subroutine z_vect_axpby_a - + subroutine z_vect_mlt_v(x, y, info) use psi_serial_mod implicit none @@ -651,7 +651,7 @@ contains info = 0 if (allocated(y%v)) & & call y%v%mlt(x,info) - + end subroutine z_vect_mlt_a @@ -668,7 +668,7 @@ contains info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) - + end subroutine z_vect_mlt_a_2 subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) @@ -717,7 +717,7 @@ contains integer(psb_ipk_) :: i, n info = 0 - + if (allocated(z%v).and.allocated(x%v)) & & call z%v%mlt(alpha,x%v,y,beta,info) @@ -728,14 +728,14 @@ contains implicit none class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha - + if (allocated(x%v)) call x%v%scal(alpha) end subroutine z_vect_scal subroutine z_vect_absval1(x) class(psb_z_vect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%absval() @@ -744,19 +744,19 @@ contains subroutine z_vect_absval2(x,y) class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y - + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(size(x%v%v)) call x%v%absval(y%v) end if end subroutine z_vect_absval2 - + function z_vect_nrm2(n,x) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (allocated(x%v)) then res = x%v%nrm2(n) else @@ -764,7 +764,7 @@ contains end if end function z_vect_nrm2 - + function z_vect_amax(n,x) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x @@ -792,7 +792,7 @@ contains end if end function z_vect_asum - + end module psb_z_vect_mod @@ -859,62 +859,63 @@ module psb_z_multivect_mod end type psb_z_multivect_type public :: psb_z_multivect, psb_z_multivect_type,& - & psb_set_multivect_default, psb_get_multivect_default + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_z_base_multivect_type private interface psb_z_multivect module procedure constructor, size_const - end interface - + end interface psb_z_multivect + class(psb_z_base_multivect_type), allocatable, target,& & save, private :: psb_z_base_multivect_default interface psb_set_multivect_default module procedure psb_z_set_multivect_default - end interface + end interface psb_set_multivect_default interface psb_get_vect_default module procedure psb_z_get_multivect_default - end interface + end interface psb_get_vect_default contains - + subroutine psb_z_set_multivect_default(v) implicit none class(psb_z_base_multivect_type), intent(in) :: v - + if (allocated(psb_z_base_multivect_default)) then deallocate(psb_z_base_multivect_default) end if allocate(psb_z_base_multivect_default, mold=v) end subroutine psb_z_set_multivect_default - + function psb_z_get_multivect_default(v) result(res) implicit none class(psb_z_multivect_type), intent(in) :: v class(psb_z_base_multivect_type), pointer :: res - + res => psb_z_get_base_multivect_default() - + end function psb_z_get_multivect_default - + function psb_z_get_base_multivect_default() result(res) implicit none class(psb_z_base_multivect_type), pointer :: res - + if (.not.allocated(psb_z_base_multivect_default)) then allocate(psb_z_base_multivect_type :: psb_z_base_multivect_default) end if res => psb_z_base_multivect_default - + end function psb_z_get_base_multivect_default - + subroutine z_vect_clone(x,y,info) implicit none class(psb_z_multivect_type), intent(inout) :: x @@ -927,7 +928,7 @@ contains call y%bld(x%get_vect(),mold=x%v) end if end subroutine z_vect_clone - + subroutine z_vect_bld_x(x,invect,mold) complex(psb_dpk_), intent(in) :: invect(:,:) class(psb_z_multivect_type), intent(out) :: x @@ -993,19 +994,19 @@ contains subroutine z_vect_set_scal(x,val) class(psb_z_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine z_vect_set_scal subroutine z_vect_set_vect(x,val) class(psb_z_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val(:,:) - + integer(psb_ipk_) :: info if (allocated(x%v)) call x%v%set(val) - + end subroutine z_vect_set_vect @@ -1061,7 +1062,7 @@ contains res = 'NULL' if (allocated(x%v)) res = x%v%get_fmt() end function z_vect_get_fmt - + subroutine z_vect_all(m,n, x, info, mold) implicit none @@ -1069,7 +1070,7 @@ contains class(psb_z_multivect_type), intent(out) :: x class(psb_z_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - + if (present(mold)) then #ifdef HAVE_MOLD allocate(x%v,stat=info,mold=mold) @@ -1093,7 +1094,7 @@ contains integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) @@ -1121,16 +1122,16 @@ contains if (allocated(x%v)) & & call x%v%asb(m,n,info) - + end subroutine z_vect_asb subroutine z_vect_sync(x) implicit none class(psb_z_multivect_type), intent(inout) :: x - + if (allocated(x%v)) & & call x%v%sync() - + end subroutine z_vect_sync subroutine z_vect_gthab(n,idx,alpha,x,beta,y) @@ -1138,10 +1139,10 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: alpha, beta, y(:) class(psb_z_multivect_type) :: x - + if (allocated(x%v)) & & call x%v%gth(n,idx,alpha,beta,y) - + end subroutine z_vect_gthab subroutine z_vect_gthzv(n,idx,x,y) @@ -1152,7 +1153,7 @@ contains if (allocated(x%v)) & & call x%v%gth(n,idx,y) - + end subroutine z_vect_gthzv subroutine z_vect_gthzv_x(i,n,idx,x,y) @@ -1164,7 +1165,7 @@ contains if (allocated(x%v)) & & call x%v%gth(i,n,idx,y) - + end subroutine z_vect_gthzv_x subroutine z_vect_sctb(n,idx,x,beta,y) @@ -1172,7 +1173,7 @@ contains integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:) class(psb_z_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(n,idx,x,beta) @@ -1184,7 +1185,7 @@ contains class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: beta, x(:) class(psb_z_multivect_type) :: y - + if (allocated(y%v)) & & call y%v%sct(i,n,idx,x,beta) @@ -1196,13 +1197,13 @@ contains implicit none class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if - + end subroutine z_vect_free subroutine z_vect_ins(n,irl,val,dupl,x,info) @@ -1221,9 +1222,9 @@ contains info = psb_err_invalid_vect_state_ return end if - + call x%v%ins(n,irl,val,dupl,info) - + end subroutine z_vect_ins @@ -1248,7 +1249,7 @@ contains end if end subroutine z_vect_cnv - + !!$ function z_vect_dot_v(n,x,y) result(res) !!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x, y diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index e5d6cce8..4630652e 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -420,3 +420,97 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) return end subroutine psb_calloc_vect_r2 + + +subroutine psb_calloc_multivect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_calloc_multivect + use psi_mod + implicit none + + !....parameters... + type(psb_c_multivect_type), allocatable, intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_c_base_multivect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,n_,info) + if (info == 0) call x%zero() + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_calloc_multivect diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index d9091f56..af6cdd1e 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -400,3 +400,93 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) return end subroutine psb_casb_vect_r2 + + +subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) + use psb_base_mod, psb_protect_name => psb_casb_multivect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_c_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), optional, intent(in) :: n + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + logical :: scratch_ + + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + int_err(1) = 0 + name = 'psb_cgeasb' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (present(n)) then + n_ = n + else + if (allocated(x%v)) then + n_ = x%v%get_ncols() + else + n_ = 1 + end if + endif + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,n_,mold=mold) + else + call x%asb(ncol,n_,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_casb_multivect + diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 79496684..af8bfb50 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -420,3 +420,97 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) return end subroutine psb_dalloc_vect_r2 + + +subroutine psb_dalloc_multivect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_dalloc_multivect + use psi_mod + implicit none + + !....parameters... + type(psb_d_multivect_type), allocatable, intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_d_base_multivect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,n_,info) + if (info == 0) call x%zero() + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dalloc_multivect diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index fd0581d8..789c9a08 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -400,3 +400,93 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) return end subroutine psb_dasb_vect_r2 + + +subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) + use psb_base_mod, psb_protect_name => psb_dasb_multivect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_d_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), optional, intent(in) :: n + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + logical :: scratch_ + + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + int_err(1) = 0 + name = 'psb_dgeasb' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (present(n)) then + n_ = n + else + if (allocated(x%v)) then + n_ = x%v%get_ncols() + else + n_ = 1 + end if + endif + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,n_,mold=mold) + else + call x%asb(ncol,n_,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dasb_multivect + diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 86b4d79e..fb8734f4 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -420,3 +420,97 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) return end subroutine psb_ialloc_vect_r2 + + +subroutine psb_ialloc_multivect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_ialloc_multivect + use psi_mod + implicit none + + !....parameters... + type(psb_i_multivect_type), allocatable, intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_i_base_multivect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,n_,info) + if (info == 0) call x%zero() + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ialloc_multivect diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 14e90cd4..bb9e9aaf 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -400,3 +400,93 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) return end subroutine psb_iasb_vect_r2 + + +subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) + use psb_base_mod, psb_protect_name => psb_iasb_multivect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_i_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), optional, intent(in) :: n + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + logical :: scratch_ + + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + int_err(1) = 0 + name = 'psb_igeasb' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (present(n)) then + n_ = n + else + if (allocated(x%v)) then + n_ = x%v%get_ncols() + else + n_ = 1 + end if + endif + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,n_,mold=mold) + else + call x%asb(ncol,n_,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_iasb_multivect + diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 8216f40a..b6a88f0a 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -420,3 +420,97 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) return end subroutine psb_salloc_vect_r2 + + +subroutine psb_salloc_multivect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_salloc_multivect + use psi_mod + implicit none + + !....parameters... + type(psb_s_multivect_type), allocatable, intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_s_base_multivect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,n_,info) + if (info == 0) call x%zero() + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_salloc_multivect diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 8063d534..bbedb30e 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -400,3 +400,93 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) return end subroutine psb_sasb_vect_r2 + + +subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) + use psb_base_mod, psb_protect_name => psb_sasb_multivect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_s_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), optional, intent(in) :: n + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + logical :: scratch_ + + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + int_err(1) = 0 + name = 'psb_sgeasb' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (present(n)) then + n_ = n + else + if (allocated(x%v)) then + n_ = x%v%get_ncols() + else + n_ = 1 + end if + endif + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,n_,mold=mold) + else + call x%asb(ncol,n_,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sasb_multivect + diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index cf861a06..9d03623c 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -420,3 +420,97 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) return end subroutine psb_zalloc_vect_r2 + + +subroutine psb_zalloc_multivect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_zalloc_multivect + use psi_mod + implicit none + + !....parameters... + type(psb_z_multivect_type), allocatable, intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_z_base_multivect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,n_,info) + if (info == 0) call x%zero() + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zalloc_multivect diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 236de817..eaa98352 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -400,3 +400,93 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) return end subroutine psb_zasb_vect_r2 + + +subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) + use psb_base_mod, psb_protect_name => psb_zasb_multivect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_z_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), optional, intent(in) :: n + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + logical :: scratch_ + + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + int_err(1) = 0 + name = 'psb_zgeasb' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (present(n)) then + n_ = n + else + if (allocated(x%v)) then + n_ = x%v%get_ncols() + else + n_ = 1 + end if + endif + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,n_,mold=mold) + else + call x%asb(ncol,n_,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zasb_multivect + diff --git a/test/fileread/runs/dfs.inp b/test/fileread/runs/dfs.inp index e41e95d6..2e982f6e 100644 --- a/test/fileread/runs/dfs.inp +++ b/test/fileread/runs/dfs.inp @@ -1,11 +1,11 @@ 11 Number of inputs -matrix_0000_of_0001.mtx ! kivap005.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or +kivap005.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or NONE sherman3_b.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html MM File format: MM: Matrix Market HB: Harwell-Boeing. -BiCG Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG +BiCGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG BJAC Preconditioner NONE DIAG BJAC CSR Storage format CSR COO JAD -3 IPART: Partition method 0: BLK 2: graph (with Metis) +2 IPART: Partition method 0: BLK 2: graph (with Metis) 2 ISTOPC 02100 ITMAX -1 ITRACE