diff --git a/base/comm/internals/psi_i2ovrl_restr_a.f90 b/base/comm/internals/psi_i2ovrl_restr_a.f90 new file mode 100644 index 00000000..36bc2566 --- /dev/null +++ b/base/comm/internals/psi_i2ovrl_restr_a.f90 @@ -0,0 +1,129 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psi_i2ovrl_restr +! These subroutines restore the overlap region of a vector; they are used +! for the transpose matrix-vector product when there is a nonempty overlap. +! +! +subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_i2ovrl_restrr1 + + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_i2pk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_i2ovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_i2ovrl_restrr1 + +subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_i2ovrl_restrr2 + + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_i2pk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_i2ovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_i2ovrl_restrr2 + diff --git a/base/comm/internals/psi_i2ovrl_save_a.f90 b/base/comm/internals/psi_i2ovrl_save_a.f90 new file mode 100644 index 00000000..55e9ae89 --- /dev/null +++ b/base/comm/internals/psi_i2ovrl_save_a.f90 @@ -0,0 +1,139 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Subroutine: psi_i2ovrl_save +! These subroutines save the overlap region of a vector; they are used +! for the transpose matrix-vector product when there is a nonempty overlap. +! +subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_i2ovrl_saver1 + + use psb_realloc_mod + + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_i2pk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_i2ovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_i2ovrl_saver1 + + +subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_i2ovrl_saver2 + + use psb_realloc_mod + + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_i2pk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_i2ovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_i2ovrl_saver2 diff --git a/base/comm/internals/psi_i2ovrl_upd_a.f90 b/base/comm/internals/psi_i2ovrl_upd_a.f90 new file mode 100644 index 00000000..c41803ef --- /dev/null +++ b/base/comm/internals/psi_i2ovrl_upd_a.f90 @@ -0,0 +1,173 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psi_i2ovrl_update +! These subroutines update the overlap region of a vector; they are used +! for the transpose matrix-vector product when there is a nonempty overlap, +! or for the application of Additive Schwarz preconditioners. +! +! +subroutine psi_i2ovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_i2ovrl_updr1 + + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_i2ovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = i2zero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_i2ovrl_updr1 + + +subroutine psi_i2ovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_i2ovrl_updr2 + + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_i2ovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = i2zero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_i2ovrl_updr2 diff --git a/base/comm/internals/psi_i2swapdata_a.F90 b/base/comm/internals/psi_i2swapdata_a.F90 new file mode 100644 index 00000000..479042c4 --- /dev/null +++ b/base/comm/internals/psi_i2swapdata_a.F90 @@ -0,0 +1,990 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_i2swapdata.F90 +! +! Subroutine: psi_i2swapdatam +! Implements the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in our +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! The first routine picks the desired exchange index list and passes it to the second. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - integer Choose overwrite or sum. +! y(:,:) - integer The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - integer Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_i2swapdatam + 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, n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + 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_idx,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,n,beta,y,d_idx,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_i2swapdatam + +subroutine psi_i2swapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_i2swapidxm + 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) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + 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 + + 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 + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_i2pk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + 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 + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int2_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int2_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (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 + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_i2swapidxm + +! +! +! Subroutine: psi_i2swapdatav +! Implements the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! The first routine picks the desired exchange index list and passes it to the second. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - integer Choose overwrite or sum. +! y(:) - integer The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - integer Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_i2swapdatav + 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 + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), 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 + integer(psb_ipk_), pointer :: d_idx(:) + 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_idx,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_idx,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_i2swapdatav + + +! +! +! Subroutine: psi_i2swapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_i2swapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_i2swapidxv + 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) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + 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 + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_i2pk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + 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 + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int2_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int2_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (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 + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_i2swapidxv diff --git a/base/comm/internals/psi_i2swaptran_a.F90 b/base/comm/internals/psi_i2swaptran_a.F90 new file mode 100644 index 00000000..f69b8aec --- /dev/null +++ b/base/comm/internals/psi_i2swaptran_a.F90 @@ -0,0 +1,1006 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_i2swaptran.F90 +! +! Subroutine: psi_i2swaptranm +! Implements the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! The first routine picks the desired exchange index list and passes it to the second. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - integer Choose overwrite or sum. +! y(:,:) - integer The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - integer Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_i2swaptranm + 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, n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + 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_idx,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,n,beta,y,d_idx,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_i2swaptranm + +subroutine psi_i2tranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_i2tranidxm + 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) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + 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 + + 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 + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_i2pk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int2_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_i2tranidxm +! +! +! Subroutine: psi_i2swaptranv +! Implements the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! The first routine picks the desired exchange index list and passes it to the second. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - integer Choose overwrite or sum. +! y(:) - integer The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - integer Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_i2swaptranv + 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 + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), 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_ + integer(psb_ipk_), pointer :: d_idx(:) + 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_idx,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_idx,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_i2swaptranv + + +! +! +! Subroutine: psi_i2tranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_i2tranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_i2tranidxv + 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) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + 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 + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_i2pk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int2_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_i2tranidxv diff --git a/base/comm/psb_i2gather_a.f90 b/base/comm/psb_i2gather_a.f90 new file mode 100644 index 00000000..9a671ef6 --- /dev/null +++ b/base/comm/psb_i2gather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_i2gather.f90 +! +! Subroutine: psb_i2gather +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - integer,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - integer,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_i2gatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_i2gatherm + implicit none + + integer(psb_i2pk_), intent(in) :: locx(:,:) + integer(psb_i2pk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_i2gatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + 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 (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=i2zero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = i2zero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_i2gatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_i2gatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - integer,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - integer,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_i2gatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_i2gatherv + implicit none + + integer(psb_i2pk_), intent(in) :: locx(:) + integer(psb_i2pk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_i2gatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + 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 (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=i2zero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = i2zero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_i2gatherv + diff --git a/base/comm/psb_i2halo_a.f90 b/base/comm/psb_i2halo_a.f90 new file mode 100644 index 00000000..f9c17fa5 --- /dev/null +++ b/base/comm/psb_i2halo_a.f90 @@ -0,0 +1,380 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_i2halo.f90 +! +! Subroutine: psb_i2halom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - integer,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_i2halom + use psi_mod + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_i2pk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_i2halom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + 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 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ; ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,i2zero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,i2one,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + 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(ione*ictxt,err_act) + + return +end subroutine psb_i2halom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_i2halov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_i2halov + use psi_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_i2pk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_i2halov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + 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 + + 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 + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ ; ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,i2zero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,i2one,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_i2halov + diff --git a/base/comm/psb_i2ovrl_a.f90 b/base/comm/psb_i2ovrl_a.f90 new file mode 100644 index 00000000..8d056e39 --- /dev/null +++ b/base/comm/psb_i2ovrl_a.f90 @@ -0,0 +1,374 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_i2ovrl.f90 +! +! Subroutine: psb_i2ovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - integer The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_i2ovrlm + use psi_mod + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_i2pk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_i2ovrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + 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 + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,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) + goto 9999 + end if + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,i2one,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_i2ovrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_i2ovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - integer The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_i2ovrlv + use psi_mod + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_i2pk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_i2ovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + 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 + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,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 + + if(info /= 0) goto 9999 + + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,i2one,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_i2ovrlv diff --git a/base/comm/psb_i2scatter_a.F90 b/base/comm/psb_i2scatter_a.F90 new file mode 100644 index 00000000..4a72458e --- /dev/null +++ b/base/comm/psb_i2scatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_i2scatter.f90 +! +! Subroutine: psb_i2scatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to all the processes. +! +! Arguments: +! globx - integer,dimension(:,:). The global matrix to scatter. +! locx - integer,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_i2scatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_i2scatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_i2pk_), intent(out), allocatable :: locx(:,:) + integer(psb_i2pk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + integer(psb_i2pk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + icomm = psb_get_mpi_comm(ictxt) + myrank = psb_get_mpi_rank(ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + rootrank = psb_get_mpi_rank(ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_i2pk_,locx(1,col),nrow,& + & psb_mpi_i2pk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_i2scatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_i2scatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to all the processes. +! +! Arguments: +! globx - integer,dimension(:). The global vector to scatter. +! locx - integer,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_i2scatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_i2scatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_i2pk_), intent(out), allocatable :: locx(:) + integer(psb_i2pk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + integer(psb_i2pk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + icomm = psb_get_mpi_comm(ictxt) + myrank = psb_get_mpi_rank(ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + rootrank = psb_get_mpi_rank(ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_i2pk_,locx,nrow,& + & psb_mpi_i2pk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_i2scatterv + diff --git a/base/modules/auxil/psb_i2_hsort_mod.f90 b/base/modules/auxil/psb_i2_hsort_mod.f90 new file mode 100644 index 00000000..0878f86e --- /dev/null +++ b/base/modules/auxil/psb_i2_hsort_mod.f90 @@ -0,0 +1,125 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_i2_hsort_mod + use psb_const_mod + + interface psb_hsort + subroutine psb_i2hsort(x,ix,dir,flag) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_i2hsort + end interface psb_hsort + + + interface psi_insert_heap + subroutine psi_i2_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_i2pk_), intent(in) :: key + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2_insert_heap + end interface psi_insert_heap + + interface psi_idx_insert_heap + subroutine psi_i2_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_i2pk_), intent(in) :: key + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2_idx_insert_heap + end interface psi_idx_insert_heap + + + interface psi_heap_get_first + subroutine psi_i2_heap_get_first(key,last,heap,dir,info) + import + implicit none + integer(psb_i2pk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2_heap_get_first + end interface psi_heap_get_first + + interface psi_idx_heap_get_first + subroutine psi_i2_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + integer(psb_i2pk_), intent(inout) :: key + integer(psb_ipk_), intent(out) :: index + integer(psb_i2pk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2_idx_heap_get_first + end interface psi_idx_heap_get_first + + +end module psb_i2_hsort_mod diff --git a/base/modules/auxil/psb_i2_ip_reord_mod.F90 b/base/modules/auxil/psb_i2_ip_reord_mod.F90 new file mode 100644 index 00000000..985b3cd4 --- /dev/null +++ b/base/modules/auxil/psb_i2_ip_reord_mod.F90 @@ -0,0 +1,320 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Reorder (an) input vector(s) based on a list sort output. +! Based on: D. E. Knuth: The Art of Computer Programming +! vol. 3: Sorting and Searching, Addison Wesley, 1973 +! ex. 5.2.12 +! +! +module psb_i2_ip_reord_mod + use psb_const_mod + + interface psb_ip_reord + module procedure psb_ip_reord_i21m,& + & psb_ip_reord_i21m1, psb_ip_reord_i21m2,& + & psb_ip_reord_i21m3 + module procedure psb_ip_reord_i21e,& + & psb_ip_reord_i21e1, psb_ip_reord_i21e2,& + & psb_ip_reord_i21e3 + + + end interface + +contains + + subroutine psb_ip_reord_i21m(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_mpk_) :: lswap, lp, k + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21m + + subroutine psb_ip_reord_i21m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21m1 + + subroutine psb_ip_reord_i21m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21m2 + + subroutine psb_ip_reord_i21m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21m3 + + + subroutine psb_ip_reord_i21e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21e + + subroutine psb_ip_reord_i21e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21e1 + + subroutine psb_ip_reord_i21e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21e2 + + subroutine psb_ip_reord_i21e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_i2pk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_i2pk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_i21e3 + +end module psb_i2_ip_reord_mod diff --git a/base/modules/auxil/psb_i2_isort_mod.f90 b/base/modules/auxil/psb_i2_isort_mod.f90 new file mode 100644 index 00000000..115da75c --- /dev/null +++ b/base/modules/auxil/psb_i2_isort_mod.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_i2_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_i2isort(x,ix,dir,flag) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_i2isort + end interface psb_isort + + + + interface + subroutine psi_i2isrx_up(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2isrx_up + subroutine psi_i2isrx_dw(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2isrx_dw + subroutine psi_i2isr_up(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2isr_up + subroutine psi_i2isr_dw(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2isr_dw + subroutine psi_i2aisrx_up(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aisrx_up + subroutine psi_i2aisrx_dw(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aisrx_dw + subroutine psi_i2aisr_up(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aisr_up + subroutine psi_i2aisr_dw(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aisr_dw + end interface + + +end module psb_i2_isort_mod diff --git a/base/modules/auxil/psb_i2_msort_mod.f90 b/base/modules/auxil/psb_i2_msort_mod.f90 new file mode 100644 index 00000000..caad0971 --- /dev/null +++ b/base/modules/auxil/psb_i2_msort_mod.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_i2_msort_mod + use psb_const_mod + + interface psb_isaperm + logical function psb_i2isaperm(n,eip) + import + integer(psb_i2pk_), intent(in) :: n + integer(psb_i2pk_), intent(in) :: eip(n) + end function psb_i2isaperm + end interface psb_isaperm + + interface psb_msort_unique + subroutine psb_i2msort_u(x,nout,dir) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_i2msort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_i2msort(x,ix,dir,flag) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_i2msort + end interface psb_msort + + + interface psi_msort_up + subroutine psi_i2_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i2_msort_up + end interface psi_msort_up + interface psi_msort_dw + subroutine psi_i2_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i2_msort_dw + end interface psi_msort_dw + interface psi_amsort_up + subroutine psi_i2_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i2_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_i2_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_i2pk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_i2_amsort_dw + end interface psi_amsort_dw + +end module psb_i2_msort_mod diff --git a/base/modules/auxil/psb_i2_qsort_mod.f90 b/base/modules/auxil/psb_i2_qsort_mod.f90 new file mode 100644 index 00000000..944a436e --- /dev/null +++ b/base/modules/auxil/psb_i2_qsort_mod.f90 @@ -0,0 +1,123 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_i2_qsort_mod + use psb_const_mod + + + + interface psb_bsrch + function psb_i2bsrch(key,n,v) result(ipos) + import + integer(psb_ipk_) :: ipos, n + integer(psb_i2pk_) :: key + integer(psb_i2pk_) :: v(:) + end function psb_i2bsrch + end interface psb_bsrch + + interface psb_ssrch + function psb_i2ssrch(key,n,v) result(ipos) + import + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_i2pk_) :: key + integer(psb_i2pk_) :: v(:) + end function psb_i2ssrch + end interface psb_ssrch + + interface psb_qsort + subroutine psb_i2qsort(x,ix,dir,flag) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_i2qsort + end interface psb_qsort + + interface + subroutine psi_i2qsrx_up(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2qsrx_up + subroutine psi_i2qsrx_dw(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2qsrx_dw + subroutine psi_i2qsr_up(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2qsr_up + subroutine psi_i2qsr_dw(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2qsr_dw + subroutine psi_i2aqsrx_up(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aqsrx_up + subroutine psi_i2aqsrx_dw(n,x,ix) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aqsrx_dw + subroutine psi_i2aqsr_up(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aqsr_up + subroutine psi_i2aqsr_dw(n,x) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_i2aqsr_dw + end interface + +end module psb_i2_qsort_mod diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 new file mode 100644 index 00000000..4bc4da32 --- /dev/null +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_i2_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_i2_rk1 + module procedure psb_r_m_i2_rk2 + module procedure psb_r_e_i2_rk1 + module procedure psb_r_e_i2_rk2 + module procedure psb_r_me_i2_rk2 + module procedure psb_r_em_i2_rk2 + + module procedure psb_r_m_2_i2_rk1 + module procedure psb_r_e_2_i2_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_i2_rk1, psb_move_alloc_i2_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_i2_rk1, psb_cpy_i2_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_i2_rk1, psb_ensure_e_sz_i2_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_i2_rk1, psb_size_i2_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_i2pk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_i2_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_i2_rk1 + + Subroutine psb_r_m_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + integer(psb_i2pk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_i2pk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_i2_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_i2_rk2 + + + Subroutine psb_r_e_i2_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_i2pk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_i2_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_i2_rk1 + + Subroutine psb_r_e_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + integer(psb_i2pk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_i2pk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_i2_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_i2_rk2 + + Subroutine psb_r_me_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + integer(psb_i2pk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_i2pk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_i2_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_i2_rk2 + + Subroutine psb_r_em_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + integer(psb_i2pk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_i2pk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_i2_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_i2_rk2 + + Subroutine psb_r_m_2_i2_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_i2_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_i2_rk1 + + Subroutine psb_r_e_2_i2_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_i2pk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_i2_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_i2_rk1 + + + + subroutine psb_ab_cpy_i2_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_i2pk_), allocatable, intent(in) :: vin(:) + integer(psb_i2pk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_i2_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_i2_rk1 + + subroutine psb_ab_cpy_i2_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_i2pk_), allocatable, intent(in) :: vin(:,:) + integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_i2_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_i2_rk2 + + + subroutine psb_cpy_i2_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_i2pk_), intent(in) :: vin(:) + integer(psb_i2pk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_i2_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_i2_rk1 + + subroutine psb_cpy_i2_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_i2pk_), intent(in) :: vin(:,:) + integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_i2_rk2 + + + function psb_size_i2_rk1(vin) result(val) + integer(psb_epk_) :: val + integer(psb_i2pk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_i2_rk1 + + + function psb_size_i2_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + integer(psb_i2pk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_i2_rk2 + + Subroutine psb_ensure_m_sz_i2_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_i2pk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + integer(psb_i2pk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_i2_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_i2_rk1 + + Subroutine psb_ensure_e_sz_i2_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_i2pk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + integer(psb_i2pk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_i2_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_i2_rk1 + + Subroutine psb_move_alloc_i2_rk1(vin,vout,info) + use psb_error_mod + integer(psb_i2pk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_i2_rk1 + + Subroutine psb_move_alloc_i2_rk2(vin,vout,info) + use psb_error_mod + integer(psb_i2pk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_i2_rk2 + +end module psb_i2_realloc_mod diff --git a/base/modules/auxil/psi_i2_serial_mod.f90 b/base/modules/auxil/psi_i2_serial_mod.f90 new file mode 100644 index 00000000..fd71ea84 --- /dev/null +++ b/base/modules/auxil/psi_i2_serial_mod.f90 @@ -0,0 +1,133 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i2_serial_mod + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_gelp + ! 2-D version + subroutine psb_i2gelp(trans,iperm,x,info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + end subroutine psb_i2gelp + subroutine psb_i2gelpv(trans,iperm,x,info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + end subroutine psb_i2gelpv + end interface psb_gelp + + interface psb_geaxpby + subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m, n + integer(psb_i2pk_), intent (in) :: x(:,:) + integer(psb_i2pk_), intent (inout) :: y(:,:) + integer(psb_i2pk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2axpby + subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_i2pk_), intent (in) :: x(:) + integer(psb_i2pk_), intent (inout) :: y(:) + integer(psb_i2pk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2axpbyv + end interface psb_geaxpby + + interface psi_gth + subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: x(:,:), y(:),alpha,beta + end subroutine psi_i2gthmv + subroutine psi_i2gthv(n,idx,alpha,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_i2pk_) :: x(:), y(:),alpha,beta + end subroutine psi_i2gthv + subroutine psi_i2gthzmv(n,k,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: x(:,:), y(:) + + end subroutine psi_i2gthzmv + subroutine psi_i2gthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: x(:,:), y(:,:) + + end subroutine psi_i2gthzmm + subroutine psi_i2gthzv(n,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_i2pk_) :: x(:), y(:) + end subroutine psi_i2gthzv + end interface psi_gth + + interface psi_sct + subroutine psi_i2sctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: beta, x(:,:), y(:,:) + end subroutine psi_i2sctmm + subroutine psi_i2sctmv(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: beta, x(:), y(:,:) + end subroutine psi_i2sctmv + subroutine psi_i2sctv(n,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_i2pk_) :: beta, x(:), y(:) + end subroutine psi_i2sctv + end interface psi_sct + +end module psi_i2_serial_mod diff --git a/base/modules/comm/psb_e_comm_a_mod.f90 b/base/modules/comm/psb_e_comm_a_mod.f90 index 19f1cb01..46057d94 100644 --- a/base/modules/comm/psb_e_comm_a_mod.f90 +++ b/base/modules/comm/psb_e_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psb_e_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_epk_, psb_mpk_, psb_i2pk_ interface psb_ovrl subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode) diff --git a/base/modules/comm/psb_i2_comm_a_mod.f90 b/base/modules/comm/psb_i2_comm_a_mod.f90 new file mode 100644 index 00000000..09398722 --- /dev/null +++ b/base/modules/comm/psb_i2_comm_a_mod.f90 @@ -0,0 +1,123 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_i2_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_epk_, psb_mpk_, psb_i2pk_ + + interface psb_ovrl + subroutine psb_i2ovrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_i2ovrlm + subroutine psb_i2ovrlv(x,desc_a,info,work,update,mode) + import + implicit none + integer(psb_i2pk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_i2ovrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_i2halom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_i2halom + subroutine psb_i2halov(x,desc_a,info,work,tran,mode,data) + import + implicit none + integer(psb_i2pk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_i2halov + end interface psb_halo + + + interface psb_scatter + subroutine psb_i2scatterm(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_i2pk_), intent(out), allocatable :: locx(:,:) + integer(psb_i2pk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_i2scatterm + subroutine psb_i2scatterv(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_i2pk_), intent(out), allocatable :: locx(:) + integer(psb_i2pk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_i2scatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_i2gatherm(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_i2pk_), intent(in) :: locx(:,:) + integer(psb_i2pk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_i2gatherm + subroutine psb_i2gatherv(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_i2pk_), intent(in) :: locx(:) + integer(psb_i2pk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_i2gatherv + end interface psb_gather + +end module psb_i2_comm_a_mod diff --git a/base/modules/comm/psb_m_comm_a_mod.f90 b/base/modules/comm/psb_m_comm_a_mod.f90 index 91124a53..dbec118a 100644 --- a/base/modules/comm/psb_m_comm_a_mod.f90 +++ b/base/modules/comm/psb_m_comm_a_mod.f90 @@ -30,7 +30,8 @@ ! ! module psb_m_comm_a_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_epk_, psb_mpk_, psb_i2pk_ interface psb_ovrl subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode) diff --git a/base/modules/comm/psi_i2_comm_a_mod.f90 b/base/modules/comm/psi_i2_comm_a_mod.f90 new file mode 100644 index 00000000..f67b5654 --- /dev/null +++ b/base/modules/comm/psi_i2_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i2_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_ + + interface psi_swapdata + subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_i2swapdatam + subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_i2swapdatav + subroutine psi_i2swapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_i2swapidxm + subroutine psi_i2swapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_i2swapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_i2swaptranm + subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_i2swaptranv + subroutine psi_i2tranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_i2tranidxm + subroutine psi_i2tranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_i2tranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_i2ovrl_updr1(x,desc_a,update,info) + import + integer(psb_i2pk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_updr1 + subroutine psi_i2ovrl_updr2(x,desc_a,update,info) + import + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_i2pk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_saver1 + subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) + import + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_i2pk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) + import + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_i2pk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_restrr1 + subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) + import + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_i2pk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2ovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_i2_comm_a_mod + diff --git a/base/modules/comm/psi_i_comm_v_mod.f90 b/base/modules/comm/psi_i_comm_v_mod.f90 index 91b2f85a..bc4ea2a8 100644 --- a/base/modules/comm/psi_i_comm_v_mod.f90 +++ b/base/modules/comm/psi_i_comm_v_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_i_comm_v_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, & + & psb_lpk_, psb_epk_, psb_i2pk_ use psb_i_base_vect_mod, only : psb_i_base_vect_type use psb_i_base_multivect_mod, only : psb_i_base_multivect_type diff --git a/base/modules/comm/psi_l_comm_v_mod.f90 b/base/modules/comm/psi_l_comm_v_mod.f90 index 150c5bd4..4c80b090 100644 --- a/base/modules/comm/psi_l_comm_v_mod.f90 +++ b/base/modules/comm/psi_l_comm_v_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_l_comm_v_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, & + & psb_lpk_, psb_epk_, psb_i2pk_ use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_, psb_i_base_vect_type use psb_l_base_vect_mod, only : psb_l_base_vect_type use psb_l_base_multivect_mod, only : psb_l_base_multivect_type diff --git a/base/modules/penv/psi_i2_collective_mod.F90 b/base/modules/penv/psi_i2_collective_mod.F90 new file mode 100644 index 00000000..911ed938 --- /dev/null +++ b/base/modules/penv/psi_i2_collective_mod.F90 @@ -0,0 +1,1443 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i2_collective_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_max + module procedure psb_i2maxs, psb_i2maxv, psb_i2maxm, & + & psb_i2maxs_ec, psb_i2maxv_ec, psb_i2maxm_ec + end interface + + interface psb_min + module procedure psb_i2mins, psb_i2minv, psb_i2minm, & + & psb_i2mins_ec, psb_i2minv_ec, psb_i2minm_ec + end interface psb_min + + + interface psb_sum + module procedure psb_i2sums, psb_i2sumv, psb_i2summ, & + & psb_i2sums_ec, psb_i2sumv_ec, psb_i2summ_ec + end interface + + interface psb_amx + module procedure psb_i2amxs, psb_i2amxv, psb_i2amxm, & + & psb_i2amxs_ec, psb_i2amxv_ec, psb_i2amxm_ec + end interface + + interface psb_amn + module procedure psb_i2amns, psb_i2amnv, psb_i2amnm, & + & psb_i2amns_ec, psb_i2amnv_ec, psb_i2amnm_ec + end interface + + + interface psb_bcast + module procedure psb_i2bcasts, psb_i2bcastv, psb_i2bcastm, & + & psb_i2bcasts_ec, psb_i2bcastv_ec, psb_i2bcastm_ec + end interface psb_bcast + + interface psb_scan_sum + module procedure psb_i2scan_sums, psb_i2scan_sumv + end interface psb_scan_sum + + interface psb_exscan_sum + module procedure psb_i2exscan_sums, psb_i2exscan_sumv + end interface psb_exscan_sum + + interface psb_simple_a2av + module procedure psb_i2_simple_a2av + end interface psb_simple_a2av + + interface psb_simple_triad_a2av + module procedure psb_i2_e_simple_triad_a2av, psb_i2_m_simple_triad_a2av + end interface psb_simple_triad_a2av + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MAX + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_i2maxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_i2maxs + + subroutine psb_i2maxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2maxv + + subroutine psb_i2maxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2maxm + + + subroutine psb_i2maxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_i2maxs_ec + + subroutine psb_i2maxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_i2maxv_ec + + subroutine psb_i2maxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_i2maxm_ec + + + ! + ! MIN: Minimum Value + ! + + + subroutine psb_i2mins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_i2mins + + subroutine psb_i2minv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2minv + + subroutine psb_i2minm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2minm + + + subroutine psb_i2mins_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_i2mins_ec + + subroutine psb_i2minv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_i2minv_ec + + subroutine psb_i2minm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_i2minm_ec + + + + + ! + ! SUM + ! + + subroutine psb_i2sums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_i2sums + + subroutine psb_i2sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2sumv + + subroutine psb_i2summ(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2summ + + subroutine psb_i2sums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_i2sums_ec + + subroutine psb_i2sumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_i2sumv_ec + + subroutine psb_i2summ_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_i2summ_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_i2amxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_i2amxs + + subroutine psb_i2amxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2amxv + + subroutine psb_i2amxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2amxm + + + subroutine psb_i2amxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_i2amxs_ec + + subroutine psb_i2amxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_i2amxv_ec + + subroutine psb_i2amxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_i2amxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_i2amns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_i2amns + + subroutine psb_i2amnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2amnv + + subroutine psb_i2amnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_i2amn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2amnm + + + subroutine psb_i2amns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_i2amns_ec + + subroutine psb_i2amnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_i2amnv_ec + + subroutine psb_i2amnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_i2amnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_i2bcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_i2pk_,root_,ictxt,info) + +#endif + end subroutine psb_i2bcasts + + subroutine psb_i2bcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_i2pk_,root_,ictxt,info) +#endif + end subroutine psb_i2bcastv + + subroutine psb_i2bcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_i2pk_,root_,ictxt,info) +#endif + end subroutine psb_i2bcastm + + + subroutine psb_i2bcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_i2bcasts_ec + + subroutine psb_i2bcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_i2bcastv_ec + + subroutine psb_i2bcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_i2bcastm_ec + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! SCAN + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_i2scan_sums(ictxt,dat) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_i2pk_) :: dat_ + integer(psb_ipk_) :: iam, np, info + integer(psb_mpk_) :: minfo, icomm + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + icomm = psb_get_mpi_comm(ictxt) + call mpi_scan(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,minfo) + dat = dat_ +#endif + end subroutine psb_i2scan_sums + + + subroutine psb_i2exscan_sums(ictxt,dat) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_i2pk_) :: dat_ + integer(psb_ipk_) :: iam, np, info + integer(psb_mpk_) :: icomm, minfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + icomm = psb_get_mpi_comm(ictxt) + call mpi_exscan(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,icomm,minfo) + dat = dat_ +#else + dat = i2zero +#endif + end subroutine psb_i2exscan_sums + + subroutine psb_i2scan_sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info + integer(psb_mpk_) :: minfo, icomm + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + icomm = psb_get_mpi_comm(ictxt) + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_scan(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,minfo) +#endif + end subroutine psb_i2scan_sumv + + subroutine psb_i2exscan_sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_ipk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_ipk_) :: iam, np, info + integer(psb_mpk_) :: minfo, icomm + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + icomm = psb_get_mpi_comm(ictxt) + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_exscan(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,icomm,minfo) +#else + dat = i2zero +#endif + end subroutine psb_i2exscan_sumv + + subroutine psb_i2_simple_a2av(valsnd,sdsz,bsdindx,& + & valrcv,rvsz,brvindx,ictxt,info) + use psi_i2_p2p_mod + implicit none + integer(psb_i2pk_), intent(in) :: valsnd(:) + integer(psb_i2pk_), intent(out) :: valrcv(:) + integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz + + call psb_info(ictxt,iam,np) + + if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then + idx = bsdindx(ip+1) + call psb_snd(ictxt,valsnd(idx+1:idx+sz),ip) + end if + end do + + do ip = 0, np-1 + sz = rvsz(ip+1) + if (sz > 0) then + idx = brvindx(ip+1) + call psb_rcv(ictxt,valrcv(idx+1:idx+sz),ip) + end if + end do + + end subroutine psb_i2_simple_a2av + + subroutine psb_i2_m_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& + & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_i2pk_), intent(in) :: valsnd(:) + integer(psb_mpk_), intent(in) :: iasnd(:), jasnd(:) + integer(psb_i2pk_), intent(out) :: valrcv(:) + integer(psb_mpk_), intent(out) :: iarcv(:), jarcv(:) + integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(out) :: info + + !Local variables + integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm + integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) + + call psb_info(ictxt,iam,np) + + icomm = psb_get_mpi_comm(ictxt) + + if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then + prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + idx = brvindx(ip+1) + p2ptag = psb_int2_tag + call mpi_irecv(valrcv(idx+1:idx+sz),sz,& + & psb_mpi_i2pk_,prcid(ip+1),& + & p2ptag, icomm,rvhd(ip+1,1),iret) + p2ptag = psb_int_swap_tag + call mpi_irecv(iarcv(idx+1:idx+sz),sz,& + & psb_mpi_mpk_,prcid(ip+1),& + & p2ptag, icomm,rvhd(ip+1,2),iret) + call mpi_irecv(jarcv(idx+1:idx+sz),sz,& + & psb_mpi_mpk_,prcid(ip+1),& + & p2ptag, icomm,rvhd(ip+1,3),iret) + end if + Enddo + + + do ip = 0, np-1 + sz = sdsz(ip+1) + if (sz > 0) then + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + idx = bsdindx(ip+1) + p2ptag = psb_int2_tag + call mpi_send(valsnd(idx+1:idx+sz),sz,& + & psb_mpi_i2pk_,prcid(ip+1),& + & p2ptag, icomm,iret) + p2ptag = psb_int_swap_tag + call mpi_send(iasnd(idx+1:idx+sz),sz,& + & psb_mpi_mpk_,prcid(ip+1),& + & p2ptag, icomm,iret) + call mpi_send(jasnd(idx+1:idx+sz),sz,& + & psb_mpi_mpk_,prcid(ip+1),& + & p2ptag, icomm,iret) + end if + Enddo + + do ip = 0, np-1 + sz = rvsz(ip+1) + if (sz > 0) then + call mpi_wait(rvhd(ip+1,1),p2pstat,iret) + call mpi_wait(rvhd(ip+1,2),p2pstat,iret) + call mpi_wait(rvhd(ip+1,3),p2pstat,iret) + end if + Enddo + + end subroutine psb_i2_m_simple_triad_a2av + + subroutine psb_i2_e_simple_triad_a2av(valsnd,iasnd,jasnd,sdsz,bsdindx,& + & valrcv,iarcv,jarcv,rvsz,brvindx,ictxt,info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_i2pk_), intent(in) :: valsnd(:) + integer(psb_epk_), intent(in) :: iasnd(:), jasnd(:) + integer(psb_i2pk_), intent(out) :: valrcv(:) + integer(psb_epk_), intent(out) :: iarcv(:), jarcv(:) + integer(psb_mpk_), intent(in) :: bsdindx(:), brvindx(:), sdsz(:), rvsz(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(out) :: info + + !Local variables + integer(psb_ipk_) :: iam, np, i,j,k, ip, ipx, idx, sz, counter + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret, icomm + integer(psb_mpk_), allocatable :: prcid(:), rvhd(:,:) + + call psb_info(ictxt,iam,np) + + icomm = psb_get_mpi_comm(ictxt) + + if (min(size(bsdindx),size(brvindx),size(sdsz),size(rvsz)) 0) then + prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + idx = brvindx(ip+1) + p2ptag = psb_int2_tag + call mpi_irecv(valrcv(idx+1:idx+sz),sz,& + & psb_mpi_i2pk_,prcid(ip+1),& + & p2ptag, icomm,rvhd(ip+1,1),iret) + p2ptag = psb_int_swap_tag + call mpi_irecv(iarcv(idx+1:idx+sz),sz,& + & psb_mpi_epk_,prcid(ip+1),& + & p2ptag, icomm,rvhd(ip+1,2),iret) + call mpi_irecv(jarcv(idx+1:idx+sz),sz,& + & psb_mpi_epk_,prcid(ip+1),& + & p2ptag, icomm,rvhd(ip+1,3),iret) + end if + Enddo + + + do ip = 0, np-1 + sz = sdsz(ip+1) + if (sz > 0) then + if (prcid(ip+1)<0) prcid(ip+1) = psb_get_mpi_rank(ictxt,ip) + idx = bsdindx(ip+1) + p2ptag = psb_int2_tag + call mpi_send(valsnd(idx+1:idx+sz),sz,& + & psb_mpi_r_dpk_,prcid(ip+1),& + & p2ptag, icomm,iret) + p2ptag = psb_int_swap_tag + call mpi_send(iasnd(idx+1:idx+sz),sz,& + & psb_mpi_epk_,prcid(ip+1),& + & p2ptag, icomm,iret) + call mpi_send(jasnd(idx+1:idx+sz),sz,& + & psb_mpi_epk_,prcid(ip+1),& + & p2ptag, icomm,iret) + end if + Enddo + + do ip = 0, np-1 + sz = rvsz(ip+1) + if (sz > 0) then + call mpi_wait(rvhd(ip+1,1),p2pstat,iret) + call mpi_wait(rvhd(ip+1,2),p2pstat,iret) + call mpi_wait(rvhd(ip+1,3),p2pstat,iret) + end if + Enddo + + end subroutine psb_i2_e_simple_triad_a2av + + +end module psi_i2_collective_mod diff --git a/base/modules/penv/psi_i2_p2p_mod.F90 b/base/modules/penv/psi_i2_p2p_mod.F90 new file mode 100644 index 00000000..84bf7712 --- /dev/null +++ b/base/modules/penv/psi_i2_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_i2_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_i2snds, psb_i2sndv, psb_i2sndm, & + & psb_i2snds_ec, psb_i2sndv_ec, psb_i2sndm_ec + end interface + + interface psb_rcv + module procedure psb_i2rcvs, psb_i2rcvv, psb_i2rcvm, & + & psb_i2rcvs_ec, psb_i2rcvv_ec, psb_i2rcvm_ec + end interface + +contains + + subroutine psb_i2snds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_i2snds + + subroutine psb_i2sndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_i2sndv + + subroutine psb_i2sndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_i2sndm + + subroutine psb_i2rcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_i2rcvs + + subroutine psb_i2rcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_i2rcvv + + subroutine psb_i2rcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_i2pk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_int2_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_i2pk_,src,psb_int2_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_i2rcvm + + + subroutine psb_i2snds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_i2snds_ec + + subroutine psb_i2sndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_i2sndv_ec + + subroutine psb_i2sndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_i2sndm_ec + + subroutine psb_i2rcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_i2rcvs_ec + + subroutine psb_i2rcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_i2rcvv_ec + + subroutine psb_i2rcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_i2rcvm_ec + + +end module psi_i2_p2p_mod diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 92def010..648a1669 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -103,9 +103,9 @@ module psb_const_mod integer(psb_ipk_), save :: psb_sizeof_sp integer(psb_ipk_), save :: psb_sizeof_dp - integer(psb_ipk_), save :: psb_sizeof_i2p - integer(psb_ipk_), save :: psb_sizeof_mp = 4 - integer(psb_ipk_), save :: psb_sizeof_ep = 8 + integer(psb_ipk_), save :: psb_sizeof_i2p = 2 + integer(psb_ipk_), save :: psb_sizeof_mp = 4 + integer(psb_ipk_), save :: psb_sizeof_ep = 8 #if defined(IPK4) && defined(LPK4) integer(psb_ipk_), save :: psb_sizeof_ip = 4 @@ -145,13 +145,15 @@ module psb_const_mod ! Handy & miscellaneous constants ! integer(psb_epk_), parameter :: ezero=0, eone=1 - integer(psb_epk_), parameter :: etwo=2, ethree=3,emone=-1 + integer(psb_epk_), parameter :: etwo=2, ethree=3, emone=-1 integer(psb_mpk_), parameter :: mzero=0, mone=1 - integer(psb_mpk_), parameter :: mtwo=2, mthree=3,mmone=-1 + integer(psb_mpk_), parameter :: mtwo=2, mthree=3, mmone=-1 integer(psb_lpk_), parameter :: lzero=0, lone=1 - integer(psb_lpk_), parameter :: ltwo=2, lthree=3,lmone=-1 + integer(psb_lpk_), parameter :: ltwo=2, lthree=3, lmone=-1 integer(psb_ipk_), parameter :: izero=0, ione=1 - integer(psb_ipk_), parameter :: itwo=2, ithree=3,imone=-1 + integer(psb_ipk_), parameter :: itwo=2, ithree=3, imone=-1 + integer(psb_i2pk_), parameter :: i2zero=0, i2one=1 + integer(psb_i2pk_), parameter :: i2two=2, i2three=3, i2mone=-1 integer(psb_ipk_), parameter :: psb_root_=0 real(psb_spk_), parameter :: szero=0.0_psb_spk_, sone=1.0_psb_spk_ diff --git a/base/modules/tools/psb_i2_tools_a_mod.f90 b/base/modules/tools/psb_i2_tools_a_mod.f90 new file mode 100644 index 00000000..860a55b1 --- /dev/null +++ b/base/modules/tools/psb_i2_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_i2_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_i2pk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_i2alloc(x, desc_a, info, n, lb) + import + implicit none + integer(psb_i2pk_), 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, lb + end subroutine psb_i2alloc + subroutine psb_i2allocv(x, desc_a,info,n) + import + implicit none + integer(psb_i2pk_), 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 + end subroutine psb_i2allocv + end interface + + + interface psb_geasb + subroutine psb_i2asb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_i2pk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_i2asb + subroutine psb_i2asbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_i2pk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_i2asbv + end interface + + interface psb_gefree + subroutine psb_i2free(x, desc_a, info) + import + implicit none + integer(psb_i2pk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_i2free + subroutine psb_i2freev(x, desc_a, info) + import + implicit none + integer(psb_i2pk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_i2freev + end interface + + + interface psb_geins + subroutine psb_i2insi(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 + integer(psb_i2pk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_i2insi + subroutine psb_i2insvi(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 + integer(psb_i2pk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_i2insvi + end interface + +end module psb_i2_tools_a_mod diff --git a/base/serial/psi_i2_serial_impl.f90 b/base/serial/psi_i2_serial_impl.f90 new file mode 100644 index 00000000..30be1ddd --- /dev/null +++ b/base/serial/psi_i2_serial_impl.f90 @@ -0,0 +1,601 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m, n + integer(psb_i2pk_), intent (in) :: x(:,:) + integer(psb_i2pk_), intent (inout) :: y(:,:) + integer(psb_i2pk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = n + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 4; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 6; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if ((m>0).and.(n>0)) call i2axpby(m,n,alpha,x,lx,beta,y,ly,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psi_i2axpby + +subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_i2pk_), intent (in) :: x(:) + integer(psb_i2pk_), intent (inout) :: y(:) + integer(psb_i2pk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call i2axpby(m,ione,alpha,x,lx,beta,y,ly,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_i2axpbyv + + +subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: x(:,:), y(:),alpha,beta + + ! Locals + integer(psb_ipk_) :: i, j, pt + + if (beta == i2zero) then + if (alpha == i2zero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = i2zero + end do + end do + else if (alpha == i2one) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = x(idx(i),j) + end do + end do + else if (alpha == -i2one) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = -x(idx(i),j) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = alpha*x(idx(i),j) + end do + end do + end if + else + if (beta == i2one) then + ! Do nothing + else if (beta == -i2one) then + y(1:n*k) = -y(1:n*k) + else + y(1:n*k) = beta*y(1:n*k) + end if + + if (alpha == i2zero) then + ! do nothing + else if (alpha == i2one) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = y(pt) + x(idx(i),j) + end do + end do + else if (alpha == -i2one) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = y(pt) - x(idx(i),j) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = y(pt) + alpha*x(idx(i),j) + end do + end do + end if + end if + +end subroutine psi_i2gthmv + +subroutine psi_i2gthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_i2pk_) :: x(:), y(:),alpha,beta + + ! Locals + integer(psb_ipk_) :: i + if (beta == i2zero) then + if (alpha == i2zero) then + do i=1,n + y(i) = i2zero + end do + else if (alpha == i2one) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -i2one) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == i2one) then + ! Do nothing + else if (beta == -i2one) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == i2zero) then + ! do nothing + else if (alpha == i2one) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -i2one) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_i2gthv + +subroutine psi_i2gthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i + + + do i=1,n + y(i,1:k)=x(idx(i),1:k) + end do + +end subroutine psi_i2gthzmm + +subroutine psi_i2gthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: x(:,:), y(:) + + ! Locals + integer(psb_ipk_) :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_i2gthzmv + +subroutine psi_i2gthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_i2pk_) :: x(:), y(:) + + ! Locals + integer(psb_ipk_) :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_i2gthzv + +subroutine psi_i2sctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == i2zero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == i2one) then + do i=1,n + y(idx(i),1:k) = y(idx(i),1:k)+x(i,1:k) + end do + else + do i=1,n + y(idx(i),1:k) = beta*y(idx(i),1:k)+x(i,1:k) + end do + end if +end subroutine psi_i2sctmm + +subroutine psi_i2sctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_i2pk_) :: beta, x(:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j, pt + + if (beta == i2zero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == i2one) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_i2sctmv + +subroutine psi_i2sctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_i2pk_) :: beta, x(:), y(:) + + ! Locals + integer(psb_ipk_) :: i + + if (beta == i2zero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == i2one) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if +end subroutine psi_i2sctv + +subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + integer(psb_i2pk_) X(lldx,*), Y(lldy,*) + integer(psb_i2pk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='i2axpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.i2zero) then + if (beta.eq.i2zero) then + do j=1, n + do i=1,m + y(i,j) = i2zero + enddo + enddo + else if (beta.eq.i2one) then + ! + ! Do nothing! + ! + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.i2one) then + + if (beta.eq.i2zero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.i2one) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-i2one) then + + if (beta.eq.i2zero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.i2one) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.i2zero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.i2one) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine i2axpby diff --git a/base/tools/psb_i2allc_a.f90 b/base/tools/psb_i2allc_a.f90 new file mode 100644 index 00000000..3d453ea8 --- /dev/null +++ b/base/tools/psb_i2allc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_i2allc.f90 +! +! Function: psb_i2alloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_i2alloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_i2alloc + use psi_mod + implicit none + + !....parameters... + integer(psb_i2pk_), 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, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + 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_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='integer(psb_i2pk_)') + goto 9999 + endif + + x(:,:) = i2zero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_i2alloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_i2allocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_i2allocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_i2allocv + use psi_mod + implicit none + + !....parameters... + integer(psb_i2pk_), 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_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + 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.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='integer(psb_i2pk_)') + goto 9999 + endif + + x(:) = i2zero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_i2allocv + diff --git a/base/tools/psb_i2asb_a.f90 b/base/tools/psb_i2asb_a.f90 new file mode 100644 index 00000000..4e7cc9b0 --- /dev/null +++ b/base/tools/psb_i2asb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_i2asb.f90 +! +! Subroutine: psb_i2asb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_i2asb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_i2asb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_i2pk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_i2geasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + 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_i2asb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_i2asb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_i2asbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_i2asbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_i2pk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_i2geasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + 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.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + 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 + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + 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_i2asbv diff --git a/base/tools/psb_i2free_a.f90 b/base/tools/psb_i2free_a.f90 new file mode 100644 index 00000000..5e673626 --- /dev/null +++ b/base/tools/psb_i2free_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_i2free.f90 +! +! Subroutine: psb_i2free +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_i2free(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_i2free + implicit none + + !....parameters... + integer(psb_i2pk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_i2free' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + 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 + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_i2free + + + +! Subroutine: psb_i2freev +! frees a dense matrix structure +! +! Arguments: +! x(:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_i2freev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_i2freev + implicit none + !....parameters... + integer(psb_i2pk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_i2freev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + 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)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_i2freev diff --git a/base/tools/psb_i2ins_a.f90 b/base/tools/psb_i2ins_a.f90 new file mode 100644 index 00000000..76d7c260 --- /dev/null +++ b/base/tools/psb_i2ins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_i2insvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - integer The source dense submatrix. +! x(:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_i2insvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_i2insvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_i2pk_), intent(in) :: val(:) + integer(psb_i2pk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_i2insvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_i2insvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_i2insi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - integer The source dense submatrix. +! x(:,:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_i2insi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_i2insi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_i2pk_), intent(in) :: val(:,:) + integer(psb_i2pk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_i2insi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_i2insi + diff --git a/test/kernel/d_file_spmv.f90 b/test/kernel/d_file_spmv.f90 index 3f0baa1b..bc4bb38d 100644 --- a/test/kernel/d_file_spmv.f90 +++ b/test/kernel/d_file_spmv.f90 @@ -35,7 +35,8 @@ program d_file_spmv implicit none ! input parameters - character(len=40) :: kmethd, ptype, mtrx_file, rhs_file + character(len=40) :: kmethd, ptype + character(len=512) :: mtrx_file, rhs_file ! sparse matrices type(psb_dspmat_type) :: a, aux_a