From 05929a80c5810beeda488a1f3a9705b3ca450a8e Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 16 Jul 2015 18:58:10 +0000 Subject: [PATCH] New internals for ovrl on multivectors. --- base/internals/Makefile | 7 +- base/internals/psi_covrl_restr.f90 | 200 +++++++++++++++++ base/internals/psi_covrl_save.f90 | 227 +++++++++++++++++++ base/internals/psi_covrl_upd.f90 | 323 +++++++++++++++++++++++++++ base/internals/psi_dovrl_restr.f90 | 200 +++++++++++++++++ base/internals/psi_dovrl_save.f90 | 227 +++++++++++++++++++ base/internals/psi_dovrl_upd.f90 | 323 +++++++++++++++++++++++++++ base/internals/psi_iovrl_restr.f90 | 200 +++++++++++++++++ base/internals/psi_iovrl_save.f90 | 227 +++++++++++++++++++ base/internals/psi_iovrl_upd.f90 | 323 +++++++++++++++++++++++++++ base/internals/psi_sovrl_restr.f90 | 200 +++++++++++++++++ base/internals/psi_sovrl_save.f90 | 227 +++++++++++++++++++ base/internals/psi_sovrl_upd.f90 | 323 +++++++++++++++++++++++++++ base/internals/psi_zovrl_restr.f90 | 200 +++++++++++++++++ base/internals/psi_zovrl_save.f90 | 227 +++++++++++++++++++ base/internals/psi_zovrl_upd.f90 | 323 +++++++++++++++++++++++++++ base/modules/psb_c_base_vect_mod.f90 | 45 +++- base/modules/psb_d_base_vect_mod.f90 | 45 +++- base/modules/psb_i_base_vect_mod.f90 | 45 +++- base/modules/psb_s_base_vect_mod.f90 | 45 +++- base/modules/psb_z_base_vect_mod.f90 | 45 +++- base/modules/psi_c_mod.f90 | 31 ++- base/modules/psi_c_serial_mod.f90 | 13 ++ base/modules/psi_d_mod.f90 | 31 ++- base/modules/psi_d_serial_mod.f90 | 13 ++ base/modules/psi_i_mod.f90 | 43 +++- base/modules/psi_i_serial_mod.f90 | 13 ++ base/modules/psi_s_mod.f90 | 31 ++- base/modules/psi_s_serial_mod.f90 | 13 ++ base/modules/psi_z_mod.f90 | 31 ++- base/modules/psi_z_serial_mod.f90 | 13 ++ base/serial/psi_c_serial_impl.f90 | 44 ++++ base/serial/psi_d_serial_impl.f90 | 44 ++++ base/serial/psi_i_serial_impl.f90 | 44 ++++ base/serial/psi_s_serial_impl.f90 | 44 ++++ base/serial/psi_z_serial_impl.f90 | 44 ++++ 36 files changed, 4392 insertions(+), 42 deletions(-) create mode 100644 base/internals/psi_covrl_restr.f90 create mode 100644 base/internals/psi_covrl_save.f90 create mode 100644 base/internals/psi_covrl_upd.f90 create mode 100644 base/internals/psi_dovrl_restr.f90 create mode 100644 base/internals/psi_dovrl_save.f90 create mode 100644 base/internals/psi_dovrl_upd.f90 create mode 100644 base/internals/psi_iovrl_restr.f90 create mode 100644 base/internals/psi_iovrl_save.f90 create mode 100644 base/internals/psi_iovrl_upd.f90 create mode 100644 base/internals/psi_sovrl_restr.f90 create mode 100644 base/internals/psi_sovrl_save.f90 create mode 100644 base/internals/psi_sovrl_upd.f90 create mode 100644 base/internals/psi_zovrl_restr.f90 create mode 100644 base/internals/psi_zovrl_save.f90 create mode 100644 base/internals/psi_zovrl_upd.f90 diff --git a/base/internals/Makefile b/base/internals/Makefile index 3b38f85c..d656c510 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -5,7 +5,12 @@ FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ psi_sort_dl.o \ psi_bld_tmphalo.o\ psi_sort_dl.o \ - psi_desc_impl.o psi_ovrl_restr.o psi_ovrl_save.o psi_ovrl_upd.o + psi_desc_impl.o \ + psi_iovrl_restr.o psi_iovrl_save.o psi_iovrl_upd.o \ + psi_sovrl_restr.o psi_sovrl_save.o psi_sovrl_upd.o \ + psi_dovrl_restr.o psi_dovrl_save.o psi_dovrl_upd.o \ + psi_covrl_restr.o psi_covrl_save.o psi_covrl_upd.o \ + psi_zovrl_restr.o psi_zovrl_save.o psi_zovrl_upd.o FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o #COBJS = avltree.o srcht.o diff --git a/base/internals/psi_covrl_restr.f90 b/base/internals/psi_covrl_restr.f90 new file mode 100644 index 00000000..1ea5ed8c --- /dev/null +++ b/base/internals/psi_covrl_restr.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_covrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restrr1 + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: 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_covrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_covrl_restrr1 + +subroutine psi_covrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restrr2 + + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: 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_covrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_covrl_restrr2 + + +subroutine psi_covrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restr_vect + use psb_c_base_vect_mod + + implicit none + + class(psb_c_base_vect_type) :: x + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restr_vect' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_restr_vect + + +subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restr_multivect + use psb_c_base_vect_mod + + implicit none + + class(psb_c_base_multivect_type) :: x + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_covrl_restr_mv' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_restr_multivect + + diff --git a/base/internals/psi_covrl_save.f90 b/base/internals/psi_covrl_save.f90 new file mode 100644 index 00000000..b02446cf --- /dev/null +++ b/base/internals/psi_covrl_save.f90 @@ -0,0 +1,227 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_covrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_saver1 + + use psb_realloc_mod + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), 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_covrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_covrl_saver1 + + +subroutine psi_covrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_saver2 + + use psb_realloc_mod + + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), 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_covrl_saver2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_covrl_saver2 + + +subroutine psi_covrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_save_vect + use psb_realloc_mod + use psb_c_base_vect_mod + + implicit none + + class(psb_c_base_vect_type) :: x + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_save_vect + + + +subroutine psi_covrl_save_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_save_multivect + use psb_realloc_mod + use psb_c_base_vect_mod + + implicit none + + class(psb_c_base_multivect_type) :: x + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 = x%get_ncols() + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_save_multivect diff --git a/base/internals/psi_covrl_upd.f90 b/base/internals/psi_covrl_upd.f90 new file mode 100644 index 00000000..cc4c1ba1 --- /dev/null +++ b/base/internals/psi_covrl_upd.f90 @@ -0,0 +1,323 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_covrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_updr1 + + implicit none + + complex(psb_spk_), 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_covrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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) = czero + 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_covrl_updr1 + + +subroutine psi_covrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_updr2 + + implicit none + + complex(psb_spk_), 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_covrl_updr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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,:) = czero + 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_covrl_updr2 + + +subroutine psi_covrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_upd_vect + use psb_realloc_mod + use psb_c_base_vect_mod + + implicit none + + class(psb_c_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_spk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_covrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = czero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_upd_vect + +subroutine psi_covrl_upd_multivect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_upd_multivect + use psb_realloc_mod + use psb_c_base_vect_mod + + implicit none + + class(psb_c_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_spk_), allocatable :: xs(:,:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_covrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = czero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_upd_multivect diff --git a/base/internals/psi_dovrl_restr.f90 b/base/internals/psi_dovrl_restr.f90 new file mode 100644 index 00000000..4cd67bd7 --- /dev/null +++ b/base/internals/psi_dovrl_restr.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_dovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restrr1 + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_) :: 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_dovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_dovrl_restrr1 + +subroutine psi_dovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restrr2 + + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_) :: 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_dovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_dovrl_restrr2 + + +subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restr_vect + use psb_d_base_vect_mod + + implicit none + + class(psb_d_base_vect_type) :: x + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_restr_vect' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_restr_vect + + +subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restr_multivect + use psb_d_base_vect_mod + + implicit none + + class(psb_d_base_multivect_type) :: x + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_restr_mv' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_restr_multivect + + diff --git a/base/internals/psi_dovrl_save.f90 b/base/internals/psi_dovrl_save.f90 new file mode 100644 index 00000000..418d8e31 --- /dev/null +++ b/base/internals/psi_dovrl_save.f90 @@ -0,0 +1,227 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_dovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_saver1 + + use psb_realloc_mod + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), 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_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_dovrl_saver1 + + +subroutine psi_dovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_saver2 + + use psb_realloc_mod + + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), 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_dovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_dovrl_saver2 + + +subroutine psi_dovrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_save_vect + use psb_realloc_mod + use psb_d_base_vect_mod + + implicit none + + class(psb_d_base_vect_type) :: x + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_save_vect + + + +subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_save_multivect + use psb_realloc_mod + use psb_d_base_vect_mod + + implicit none + + class(psb_d_base_multivect_type) :: x + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 = x%get_ncols() + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_save_multivect diff --git a/base/internals/psi_dovrl_upd.f90 b/base/internals/psi_dovrl_upd.f90 new file mode 100644 index 00000000..f7ab167b --- /dev/null +++ b/base/internals/psi_dovrl_upd.f90 @@ -0,0 +1,323 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_dovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_updr1 + + implicit none + + real(psb_dpk_), 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_dovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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) = dzero + 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_dovrl_updr1 + + +subroutine psi_dovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_updr2 + + implicit none + + real(psb_dpk_), 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_dovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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,:) = dzero + 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_dovrl_updr2 + + +subroutine psi_dovrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_upd_vect + use psb_realloc_mod + use psb_d_base_vect_mod + + implicit none + + class(psb_d_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_dpk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_dovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = dzero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_upd_vect + +subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_upd_multivect + use psb_realloc_mod + use psb_d_base_vect_mod + + implicit none + + class(psb_d_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_dpk_), allocatable :: xs(:,:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_dovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = dzero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_upd_multivect diff --git a/base/internals/psi_iovrl_restr.f90 b/base/internals/psi_iovrl_restr.f90 new file mode 100644 index 00000000..bf315ac2 --- /dev/null +++ b/base/internals/psi_iovrl_restr.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_iovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restrr1 + + implicit none + + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_) :: 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_iovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_iovrl_restrr1 + +subroutine psi_iovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restrr2 + + implicit none + + integer(psb_ipk_), intent(inout) :: x(:,:) + integer(psb_ipk_) :: 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_iovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_iovrl_restrr2 + + +subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restr_vect + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_vect_type) :: x + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_restr_vect' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iovrl_restr_vect + + +subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_restr_multivect + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_iovrl_restr_mv' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iovrl_restr_multivect + + diff --git a/base/internals/psi_iovrl_save.f90 b/base/internals/psi_iovrl_save.f90 new file mode 100644 index 00000000..105e338a --- /dev/null +++ b/base/internals/psi_iovrl_save.f90 @@ -0,0 +1,227 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_iovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_saver1 + + use psb_realloc_mod + + implicit none + + integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_iovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_iovrl_saver1 + + +subroutine psi_iovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_saver2 + + use psb_realloc_mod + + implicit none + + integer(psb_ipk_), intent(inout) :: x(:,:) + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_iovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_iovrl_saver2 + + +subroutine psi_iovrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_save_vect + use psb_realloc_mod + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_vect_type) :: x + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iovrl_save_vect + + + +subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_iovrl_save_multivect + use psb_realloc_mod + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 = x%get_ncols() + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iovrl_save_multivect diff --git a/base/internals/psi_iovrl_upd.f90 b/base/internals/psi_iovrl_upd.f90 new file mode 100644 index 00000000..cda2d7ce --- /dev/null +++ b/base/internals/psi_iovrl_upd.f90 @@ -0,0 +1,323 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_iovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_updr1 + + implicit none + + integer(psb_ipk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! 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_iovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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) = izero + 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_iovrl_updr1 + + +subroutine psi_iovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_updr2 + + implicit none + + integer(psb_ipk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! 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_iovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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,:) = izero + 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_iovrl_updr2 + + +subroutine psi_iovrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_upd_vect + use psb_realloc_mod + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_iovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = izero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iovrl_upd_vect + +subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_iovrl_upd_multivect + use psb_realloc_mod + use psb_i_base_vect_mod + + implicit none + + class(psb_i_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_), allocatable :: xs(:,:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_iovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = izero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_iovrl_upd_multivect diff --git a/base/internals/psi_sovrl_restr.f90 b/base/internals/psi_sovrl_restr.f90 new file mode 100644 index 00000000..25d2a9d7 --- /dev/null +++ b/base/internals/psi_sovrl_restr.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_sovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restrr1 + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: 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_sovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_sovrl_restrr1 + +subroutine psi_sovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restrr2 + + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: 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_sovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_sovrl_restrr2 + + +subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restr_vect + use psb_s_base_vect_mod + + implicit none + + class(psb_s_base_vect_type) :: x + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restr_vect' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_restr_vect + + +subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restr_multivect + use psb_s_base_vect_mod + + implicit none + + class(psb_s_base_multivect_type) :: x + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_sovrl_restr_mv' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_restr_multivect + + diff --git a/base/internals/psi_sovrl_save.f90 b/base/internals/psi_sovrl_save.f90 new file mode 100644 index 00000000..3909e5a5 --- /dev/null +++ b/base/internals/psi_sovrl_save.f90 @@ -0,0 +1,227 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_sovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_saver1 + + use psb_realloc_mod + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), 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_sovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_sovrl_saver1 + + +subroutine psi_sovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_saver2 + + use psb_realloc_mod + + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), 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_sovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_sovrl_saver2 + + +subroutine psi_sovrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_save_vect + use psb_realloc_mod + use psb_s_base_vect_mod + + implicit none + + class(psb_s_base_vect_type) :: x + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_save_vect + + + +subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_save_multivect + use psb_realloc_mod + use psb_s_base_vect_mod + + implicit none + + class(psb_s_base_multivect_type) :: x + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 = x%get_ncols() + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_save_multivect diff --git a/base/internals/psi_sovrl_upd.f90 b/base/internals/psi_sovrl_upd.f90 new file mode 100644 index 00000000..66653599 --- /dev/null +++ b/base/internals/psi_sovrl_upd.f90 @@ -0,0 +1,323 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_sovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_updr1 + + implicit none + + real(psb_spk_), 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_sovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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) = szero + 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_sovrl_updr1 + + +subroutine psi_sovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_updr2 + + implicit none + + real(psb_spk_), 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_sovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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,:) = szero + 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_sovrl_updr2 + + +subroutine psi_sovrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_upd_vect + use psb_realloc_mod + use psb_s_base_vect_mod + + implicit none + + class(psb_s_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_spk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_sovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = szero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_upd_vect + +subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_upd_multivect + use psb_realloc_mod + use psb_s_base_vect_mod + + implicit none + + class(psb_s_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_spk_), allocatable :: xs(:,:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_sovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = szero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_upd_multivect diff --git a/base/internals/psi_zovrl_restr.f90 b/base/internals/psi_zovrl_restr.f90 new file mode 100644 index 00000000..1825451b --- /dev/null +++ b/base/internals/psi_zovrl_restr.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_zovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restrr1 + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_) :: 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_zovrl_restrr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_zovrl_restrr1 + +subroutine psi_zovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restrr2 + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_) :: 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_zovrl_restrr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_zovrl_restrr2 + + +subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restr_vect + use psb_z_base_vect_mod + + implicit none + + class(psb_z_base_vect_type) :: x + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_restr_vect' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_restr_vect + + +subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restr_multivect + use psb_z_base_vect_mod + + implicit none + + class(psb_z_base_multivect_type) :: x + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_zovrl_restr_mv' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_restr_multivect + + diff --git a/base/internals/psi_zovrl_save.f90 b/base/internals/psi_zovrl_save.f90 new file mode 100644 index 00000000..972bcb73 --- /dev/null +++ b/base/internals/psi_zovrl_save.f90 @@ -0,0 +1,227 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_zovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_saver1 + + use psb_realloc_mod + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), 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_zovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_zovrl_saver1 + + +subroutine psi_zovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_saver2 + + use psb_realloc_mod + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), 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_zovrl_saver2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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_zovrl_saver2 + + +subroutine psi_zovrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_save_vect + use psb_realloc_mod + use psb_z_base_vect_mod + + implicit none + + class(psb_z_base_vect_type) :: x + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_save_vect + + + +subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_save_multivect + use psb_realloc_mod + use psb_z_base_vect_mod + + implicit none + + class(psb_z_base_multivect_type) :: x + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 = x%get_ncols() + 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 + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_save_multivect diff --git a/base/internals/psi_zovrl_upd.f90 b/base/internals/psi_zovrl_upd.f90 new file mode 100644 index 00000000..9dcaeb77 --- /dev/null +++ b/base/internals/psi_zovrl_upd.f90 @@ -0,0 +1,323 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.4 +!!$ (C) Copyright 2006, 2010, 2015 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_zovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_updr1 + + implicit none + + complex(psb_dpk_), 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_zovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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) = zzero + 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_zovrl_updr1 + + +subroutine psi_zovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_updr2 + + implicit none + + complex(psb_dpk_), 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_zovrl_updr2' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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,:) = zzero + 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_zovrl_updr2 + + +subroutine psi_zovrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_upd_vect + use psb_realloc_mod + use psb_z_base_vect_mod + + implicit none + + class(psb_z_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_dpk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_zovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = zzero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_upd_vect + +subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_upd_multivect + use psb_realloc_mod + use psb_z_base_vect_mod + + implicit none + + class(psb_z_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_dpk_), allocatable :: xs(:,:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_zovrl_updr1' + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + 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 + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = zzero + 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 x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_upd_multivect diff --git a/base/modules/psb_c_base_vect_mod.f90 b/base/modules/psb_c_base_vect_mod.f90 index 3b8b6158..074e5553 100644 --- a/base/modules/psb_c_base_vect_mod.f90 +++ b/base/modules/psb_c_base_vect_mod.f90 @@ -1457,13 +1457,15 @@ module psb_c_base_multivect_mod ! procedure, pass(x) :: gthab => c_base_mlv_gthab procedure, pass(x) :: gthzv => c_base_mlv_gthzv + procedure, pass(x) :: gthzm => c_base_mlv_gthzm procedure, pass(x) :: gthzv_x => c_base_mlv_gthzv_x procedure, pass(x) :: gthzbuf => c_base_mlv_gthzbuf - generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf procedure, pass(y) :: sctb => c_base_mlv_sctb + procedure, pass(y) :: sctbr2 => c_base_mlv_sctbr2 procedure, pass(y) :: sctb_x => c_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => c_base_mlv_sctb_buf - generic, public :: sct => sctb, sctb_x, sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_c_base_multivect_type interface psb_c_base_multivect @@ -2560,6 +2562,31 @@ contains call psi_gth(n,nc,idx,x%v,y) end subroutine c_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_c_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine c_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_spk_) :: y(:,:) + class(psb_c_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine c_base_mlv_gthzm ! ! New comm internals impl. @@ -2609,6 +2636,20 @@ contains end subroutine c_base_mlv_sctb + subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_spk_) :: beta, x(:,:) + class(psb_c_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine c_base_mlv_sctbr2 + subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n diff --git a/base/modules/psb_d_base_vect_mod.f90 b/base/modules/psb_d_base_vect_mod.f90 index a23195d8..2d1c3b27 100644 --- a/base/modules/psb_d_base_vect_mod.f90 +++ b/base/modules/psb_d_base_vect_mod.f90 @@ -1457,13 +1457,15 @@ module psb_d_base_multivect_mod ! procedure, pass(x) :: gthab => d_base_mlv_gthab procedure, pass(x) :: gthzv => d_base_mlv_gthzv + procedure, pass(x) :: gthzm => d_base_mlv_gthzm procedure, pass(x) :: gthzv_x => d_base_mlv_gthzv_x procedure, pass(x) :: gthzbuf => d_base_mlv_gthzbuf - generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf procedure, pass(y) :: sctb => d_base_mlv_sctb + procedure, pass(y) :: sctbr2 => d_base_mlv_sctbr2 procedure, pass(y) :: sctb_x => d_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => d_base_mlv_sctb_buf - generic, public :: sct => sctb, sctb_x, sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_d_base_multivect_type interface psb_d_base_multivect @@ -2560,6 +2562,31 @@ contains call psi_gth(n,nc,idx,x%v,y) end subroutine d_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_d_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine d_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_dpk_) :: y(:,:) + class(psb_d_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine d_base_mlv_gthzm ! ! New comm internals impl. @@ -2609,6 +2636,20 @@ contains end subroutine d_base_mlv_sctb + subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_dpk_) :: beta, x(:,:) + class(psb_d_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine d_base_mlv_sctbr2 + subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n diff --git a/base/modules/psb_i_base_vect_mod.f90 b/base/modules/psb_i_base_vect_mod.f90 index 0f8caef1..ade72be8 100644 --- a/base/modules/psb_i_base_vect_mod.f90 +++ b/base/modules/psb_i_base_vect_mod.f90 @@ -965,13 +965,15 @@ module psb_i_base_multivect_mod ! procedure, pass(x) :: gthab => i_base_mlv_gthab procedure, pass(x) :: gthzv => i_base_mlv_gthzv + procedure, pass(x) :: gthzm => i_base_mlv_gthzm procedure, pass(x) :: gthzv_x => i_base_mlv_gthzv_x procedure, pass(x) :: gthzbuf => i_base_mlv_gthzbuf - generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf procedure, pass(y) :: sctb => i_base_mlv_sctb + procedure, pass(y) :: sctbr2 => i_base_mlv_sctbr2 procedure, pass(y) :: sctb_x => i_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => i_base_mlv_sctb_buf - generic, public :: sct => sctb, sctb_x, sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_i_base_multivect_type interface psb_i_base_multivect @@ -1589,6 +1591,31 @@ contains call psi_gth(n,nc,idx,x%v,y) end subroutine i_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_i_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine i_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: y(:,:) + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine i_base_mlv_gthzm ! ! New comm internals impl. @@ -1638,6 +1665,20 @@ contains end subroutine i_base_mlv_sctb + subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_ipk_) :: beta, x(:,:) + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine i_base_mlv_sctbr2 + subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n diff --git a/base/modules/psb_s_base_vect_mod.f90 b/base/modules/psb_s_base_vect_mod.f90 index 60bb9346..eb5b4b36 100644 --- a/base/modules/psb_s_base_vect_mod.f90 +++ b/base/modules/psb_s_base_vect_mod.f90 @@ -1457,13 +1457,15 @@ module psb_s_base_multivect_mod ! procedure, pass(x) :: gthab => s_base_mlv_gthab procedure, pass(x) :: gthzv => s_base_mlv_gthzv + procedure, pass(x) :: gthzm => s_base_mlv_gthzm procedure, pass(x) :: gthzv_x => s_base_mlv_gthzv_x procedure, pass(x) :: gthzbuf => s_base_mlv_gthzbuf - generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf procedure, pass(y) :: sctb => s_base_mlv_sctb + procedure, pass(y) :: sctbr2 => s_base_mlv_sctbr2 procedure, pass(y) :: sctb_x => s_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => s_base_mlv_sctb_buf - generic, public :: sct => sctb, sctb_x, sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_s_base_multivect_type interface psb_s_base_multivect @@ -2560,6 +2562,31 @@ contains call psi_gth(n,nc,idx,x%v,y) end subroutine s_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_s_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine s_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_spk_) :: y(:,:) + class(psb_s_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine s_base_mlv_gthzm ! ! New comm internals impl. @@ -2609,6 +2636,20 @@ contains end subroutine s_base_mlv_sctb + subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + real(psb_spk_) :: beta, x(:,:) + class(psb_s_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine s_base_mlv_sctbr2 + subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n diff --git a/base/modules/psb_z_base_vect_mod.f90 b/base/modules/psb_z_base_vect_mod.f90 index bb096967..d2836df0 100644 --- a/base/modules/psb_z_base_vect_mod.f90 +++ b/base/modules/psb_z_base_vect_mod.f90 @@ -1457,13 +1457,15 @@ module psb_z_base_multivect_mod ! procedure, pass(x) :: gthab => z_base_mlv_gthab procedure, pass(x) :: gthzv => z_base_mlv_gthzv + procedure, pass(x) :: gthzm => z_base_mlv_gthzm procedure, pass(x) :: gthzv_x => z_base_mlv_gthzv_x procedure, pass(x) :: gthzbuf => z_base_mlv_gthzbuf - generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf procedure, pass(y) :: sctb => z_base_mlv_sctb + procedure, pass(y) :: sctbr2 => z_base_mlv_sctbr2 procedure, pass(y) :: sctb_x => z_base_mlv_sctb_x procedure, pass(y) :: sctb_buf => z_base_mlv_sctb_buf - generic, public :: sct => sctb, sctb_x, sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf end type psb_z_base_multivect_type interface psb_z_base_multivect @@ -2560,6 +2562,31 @@ contains call psi_gth(n,nc,idx,x%v,y) end subroutine z_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_z_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine z_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_dpk_) :: y(:,:) + class(psb_z_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine z_base_mlv_gthzm ! ! New comm internals impl. @@ -2609,6 +2636,20 @@ contains end subroutine z_base_mlv_sctb + subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + complex(psb_dpk_) :: beta, x(:,:) + class(psb_z_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine z_base_mlv_sctbr2 + subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod integer(psb_ipk_) :: i, n diff --git a/base/modules/psi_c_mod.f90 b/base/modules/psi_c_mod.f90 index 3b19977b..533df6cf 100644 --- a/base/modules/psi_c_mod.f90 +++ b/base/modules/psi_c_mod.f90 @@ -114,7 +114,7 @@ module psi_c_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_cswap_vidx_multivect - end interface + end interface psi_swapdata interface psi_swaptran @@ -196,7 +196,7 @@ module psi_c_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ctran_vidx_multivect - end interface + end interface psi_swaptran interface psi_ovrl_upd subroutine psi_covrl_updr1(x,desc_a,update,info) @@ -220,7 +220,14 @@ module psi_c_mod integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_upd_vect - end interface + subroutine psi_covrl_upd_multivect(x,desc_a,update,info) + import + class(psb_c_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_upd_multivect + end interface psi_ovrl_upd interface psi_ovrl_save subroutine psi_covrl_saver1(x,xs,desc_a,info) @@ -244,7 +251,14 @@ module psi_c_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_save_vect - end interface + subroutine psi_covrl_save_multivect(x,xs,desc_a,info) + import + class(psb_c_base_multivect_type) :: x + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_save_multivect + end interface psi_ovrl_save interface psi_ovrl_restore subroutine psi_covrl_restrr1(x,xs,desc_a,info) @@ -268,7 +282,14 @@ module psi_c_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_restr_vect - end interface + subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_c_base_multivect_type) :: x + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_restr_multivect + end interface psi_ovrl_restore end module psi_c_mod diff --git a/base/modules/psi_c_serial_mod.f90 b/base/modules/psi_c_serial_mod.f90 index ef6f6994..f932bb09 100644 --- a/base/modules/psi_c_serial_mod.f90 +++ b/base/modules/psi_c_serial_mod.f90 @@ -62,6 +62,13 @@ module psi_c_serial_mod complex(psb_spk_) :: x(:,:), y(:) end subroutine psi_cgthzmv + subroutine psi_cgthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_spk_) :: x(:,:), y(:,:) + + end subroutine psi_cgthzmm subroutine psi_cgthzv(n,idx,x,y) import :: psb_ipk_, psb_spk_ implicit none @@ -71,6 +78,12 @@ module psi_c_serial_mod end interface psi_gth interface psi_sct + subroutine psi_csctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_spk_) :: beta, x(:,:), y(:,:) + end subroutine psi_csctmm subroutine psi_csctmv(n,k,idx,x,beta,y) import :: psb_ipk_, psb_spk_ implicit none diff --git a/base/modules/psi_d_mod.f90 b/base/modules/psi_d_mod.f90 index b1f805d2..47bfb831 100644 --- a/base/modules/psi_d_mod.f90 +++ b/base/modules/psi_d_mod.f90 @@ -114,7 +114,7 @@ module psi_d_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dswap_vidx_multivect - end interface + end interface psi_swapdata interface psi_swaptran @@ -196,7 +196,7 @@ module psi_d_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dtran_vidx_multivect - end interface + end interface psi_swaptran interface psi_ovrl_upd subroutine psi_dovrl_updr1(x,desc_a,update,info) @@ -220,7 +220,14 @@ module psi_d_mod integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_upd_vect - end interface + subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) + import + class(psb_d_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_upd_multivect + end interface psi_ovrl_upd interface psi_ovrl_save subroutine psi_dovrl_saver1(x,xs,desc_a,info) @@ -244,7 +251,14 @@ module psi_d_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_save_vect - end interface + subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) + import + class(psb_d_base_multivect_type) :: x + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_save_multivect + end interface psi_ovrl_save interface psi_ovrl_restore subroutine psi_dovrl_restrr1(x,xs,desc_a,info) @@ -268,7 +282,14 @@ module psi_d_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_restr_vect - end interface + subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_d_base_multivect_type) :: x + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_restr_multivect + end interface psi_ovrl_restore end module psi_d_mod diff --git a/base/modules/psi_d_serial_mod.f90 b/base/modules/psi_d_serial_mod.f90 index 1eb1bc36..19dedf53 100644 --- a/base/modules/psi_d_serial_mod.f90 +++ b/base/modules/psi_d_serial_mod.f90 @@ -62,6 +62,13 @@ module psi_d_serial_mod real(psb_dpk_) :: x(:,:), y(:) end subroutine psi_dgthzmv + subroutine psi_dgthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + real(psb_dpk_) :: x(:,:), y(:,:) + + end subroutine psi_dgthzmm subroutine psi_dgthzv(n,idx,x,y) import :: psb_ipk_, psb_dpk_ implicit none @@ -71,6 +78,12 @@ module psi_d_serial_mod end interface psi_gth interface psi_sct + subroutine psi_dsctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + real(psb_dpk_) :: beta, x(:,:), y(:,:) + end subroutine psi_dsctmm subroutine psi_dsctmv(n,k,idx,x,beta,y) import :: psb_ipk_, psb_dpk_ implicit none diff --git a/base/modules/psi_i_mod.f90 b/base/modules/psi_i_mod.f90 index 47222418..e3568ae9 100644 --- a/base/modules/psi_i_mod.f90 +++ b/base/modules/psi_i_mod.f90 @@ -119,7 +119,7 @@ module psi_i_mod type(psb_desc_type), intent(in) :: desc integer(psb_ipk_), intent(out) :: info end subroutine psi_fnd_owner - end interface + end interface psi_fnd_owner interface psi_bld_tmphalo subroutine psi_bld_tmphalo(desc,info) @@ -127,7 +127,7 @@ module psi_i_mod type(psb_desc_type), intent(inout) :: desc integer(psb_ipk_), intent(out) :: info end subroutine psi_bld_tmphalo - end interface + end interface psi_bld_tmphalo interface psi_bld_tmpovrl @@ -137,7 +137,7 @@ module psi_i_mod type(psb_desc_type), intent(inout) :: desc integer(psb_ipk_), intent(out) :: info end subroutine psi_bld_tmpovrl - end interface + end interface psi_bld_tmpovrl interface psi_cnv_dsc subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) @@ -147,7 +147,7 @@ module psi_i_mod integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type), optional, intent(in) :: mold end subroutine psi_cnv_dsc - end interface + end interface psi_cnv_dsc interface psi_renum_index subroutine psi_renum_index(iperm,idx,info) @@ -156,7 +156,7 @@ module psi_i_mod integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(inout) :: idx(:) end subroutine psi_renum_index - end interface + end interface psi_renum_index interface psi_inner_cnv subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) @@ -183,7 +183,7 @@ module psi_i_mod integer(psb_ipk_), intent(in) :: x(:) integer(psb_ipk_), intent(out) :: y(:) end subroutine psi_inner_cnv2 - end interface + end interface psi_inner_cnv interface subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) @@ -274,7 +274,7 @@ module psi_i_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_iswap_vidx_multivect - end interface + end interface psi_swapdata interface psi_swaptran @@ -356,7 +356,7 @@ module psi_i_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_itran_vidx_multivect - end interface + end interface psi_swaptran interface psi_ovrl_upd subroutine psi_iovrl_updr1(x,desc_a,update,info) @@ -380,7 +380,14 @@ module psi_i_mod integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_upd_vect - end interface + subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) + import + class(psb_i_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_upd_multivect + end interface psi_ovrl_upd interface psi_ovrl_save subroutine psi_iovrl_saver1(x,xs,desc_a,info) @@ -404,7 +411,14 @@ module psi_i_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_save_vect - end interface + subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) + import + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_save_multivect + end interface psi_ovrl_save interface psi_ovrl_restore subroutine psi_iovrl_restrr1(x,xs,desc_a,info) @@ -428,7 +442,14 @@ module psi_i_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_restr_vect - end interface + subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_restr_multivect + end interface psi_ovrl_restore end module psi_i_mod diff --git a/base/modules/psi_i_serial_mod.f90 b/base/modules/psi_i_serial_mod.f90 index f5274150..503e47b2 100644 --- a/base/modules/psi_i_serial_mod.f90 +++ b/base/modules/psi_i_serial_mod.f90 @@ -62,6 +62,13 @@ module psi_i_serial_mod integer(psb_ipk_) :: x(:,:), y(:) end subroutine psi_igthzmv + subroutine psi_igthzmm(n,k,idx,x,y) + import :: psb_ipk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_ipk_) :: x(:,:), y(:,:) + + end subroutine psi_igthzmm subroutine psi_igthzv(n,idx,x,y) import :: psb_ipk_ implicit none @@ -71,6 +78,12 @@ module psi_i_serial_mod end interface psi_gth interface psi_sct + subroutine psi_isctmm(n,k,idx,x,beta,y) + import :: psb_ipk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_ipk_) :: beta, x(:,:), y(:,:) + end subroutine psi_isctmm subroutine psi_isctmv(n,k,idx,x,beta,y) import :: psb_ipk_ implicit none diff --git a/base/modules/psi_s_mod.f90 b/base/modules/psi_s_mod.f90 index f45dae63..cfa5405a 100644 --- a/base/modules/psi_s_mod.f90 +++ b/base/modules/psi_s_mod.f90 @@ -114,7 +114,7 @@ module psi_s_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_sswap_vidx_multivect - end interface + end interface psi_swapdata interface psi_swaptran @@ -196,7 +196,7 @@ module psi_s_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_stran_vidx_multivect - end interface + end interface psi_swaptran interface psi_ovrl_upd subroutine psi_sovrl_updr1(x,desc_a,update,info) @@ -220,7 +220,14 @@ module psi_s_mod integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_upd_vect - end interface + subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) + import + class(psb_s_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_upd_multivect + end interface psi_ovrl_upd interface psi_ovrl_save subroutine psi_sovrl_saver1(x,xs,desc_a,info) @@ -244,7 +251,14 @@ module psi_s_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_save_vect - end interface + subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) + import + class(psb_s_base_multivect_type) :: x + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_save_multivect + end interface psi_ovrl_save interface psi_ovrl_restore subroutine psi_sovrl_restrr1(x,xs,desc_a,info) @@ -268,7 +282,14 @@ module psi_s_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_restr_vect - end interface + subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_s_base_multivect_type) :: x + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_restr_multivect + end interface psi_ovrl_restore end module psi_s_mod diff --git a/base/modules/psi_s_serial_mod.f90 b/base/modules/psi_s_serial_mod.f90 index 64dc604e..072538db 100644 --- a/base/modules/psi_s_serial_mod.f90 +++ b/base/modules/psi_s_serial_mod.f90 @@ -62,6 +62,13 @@ module psi_s_serial_mod real(psb_spk_) :: x(:,:), y(:) end subroutine psi_sgthzmv + subroutine psi_sgthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + real(psb_spk_) :: x(:,:), y(:,:) + + end subroutine psi_sgthzmm subroutine psi_sgthzv(n,idx,x,y) import :: psb_ipk_, psb_spk_ implicit none @@ -71,6 +78,12 @@ module psi_s_serial_mod end interface psi_gth interface psi_sct + subroutine psi_ssctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + real(psb_spk_) :: beta, x(:,:), y(:,:) + end subroutine psi_ssctmm subroutine psi_ssctmv(n,k,idx,x,beta,y) import :: psb_ipk_, psb_spk_ implicit none diff --git a/base/modules/psi_z_mod.f90 b/base/modules/psi_z_mod.f90 index d3e8eb8e..d9d8cd01 100644 --- a/base/modules/psi_z_mod.f90 +++ b/base/modules/psi_z_mod.f90 @@ -114,7 +114,7 @@ module psi_z_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_zswap_vidx_multivect - end interface + end interface psi_swapdata interface psi_swaptran @@ -196,7 +196,7 @@ module psi_z_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ztran_vidx_multivect - end interface + end interface psi_swaptran interface psi_ovrl_upd subroutine psi_zovrl_updr1(x,desc_a,update,info) @@ -220,7 +220,14 @@ module psi_z_mod integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_upd_vect - end interface + subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) + import + class(psb_z_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_upd_multivect + end interface psi_ovrl_upd interface psi_ovrl_save subroutine psi_zovrl_saver1(x,xs,desc_a,info) @@ -244,7 +251,14 @@ module psi_z_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_save_vect - end interface + subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) + import + class(psb_z_base_multivect_type) :: x + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_save_multivect + end interface psi_ovrl_save interface psi_ovrl_restore subroutine psi_zovrl_restrr1(x,xs,desc_a,info) @@ -268,7 +282,14 @@ module psi_z_mod type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_restr_vect - end interface + subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_z_base_multivect_type) :: x + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_restr_multivect + end interface psi_ovrl_restore end module psi_z_mod diff --git a/base/modules/psi_z_serial_mod.f90 b/base/modules/psi_z_serial_mod.f90 index f1e37597..3de3314d 100644 --- a/base/modules/psi_z_serial_mod.f90 +++ b/base/modules/psi_z_serial_mod.f90 @@ -62,6 +62,13 @@ module psi_z_serial_mod complex(psb_dpk_) :: x(:,:), y(:) end subroutine psi_zgthzmv + subroutine psi_zgthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_dpk_) :: x(:,:), y(:,:) + + end subroutine psi_zgthzmm subroutine psi_zgthzv(n,idx,x,y) import :: psb_ipk_, psb_dpk_ implicit none @@ -71,6 +78,12 @@ module psi_z_serial_mod end interface psi_gth interface psi_sct + subroutine psi_zsctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_dpk_) :: beta, x(:,:), y(:,:) + end subroutine psi_zsctmm subroutine psi_zsctmv(n,k,idx,x,beta,y) import :: psb_ipk_, psb_dpk_ implicit none diff --git a/base/serial/psi_c_serial_impl.f90 b/base/serial/psi_c_serial_impl.f90 index 793bab17..6faa5248 100644 --- a/base/serial/psi_c_serial_impl.f90 +++ b/base/serial/psi_c_serial_impl.f90 @@ -249,6 +249,24 @@ subroutine psi_cgthv(n,idx,alpha,x,beta,y) end subroutine psi_cgthv +subroutine psi_cgthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_spk_) :: 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_cgthzmm + subroutine psi_cgthzmv(n,k,idx,x,y) use psb_const_mod @@ -287,6 +305,32 @@ subroutine psi_cgthzv(n,idx,x,y) end subroutine psi_cgthzv +subroutine psi_csctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_spk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == czero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == cone) 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_csctmm + subroutine psi_csctmv(n,k,idx,x,beta,y) use psb_const_mod diff --git a/base/serial/psi_d_serial_impl.f90 b/base/serial/psi_d_serial_impl.f90 index 7eae6fac..87de71d4 100644 --- a/base/serial/psi_d_serial_impl.f90 +++ b/base/serial/psi_d_serial_impl.f90 @@ -249,6 +249,24 @@ subroutine psi_dgthv(n,idx,alpha,x,beta,y) end subroutine psi_dgthv +subroutine psi_dgthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + real(psb_dpk_) :: 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_dgthzmm + subroutine psi_dgthzmv(n,k,idx,x,y) use psb_const_mod @@ -287,6 +305,32 @@ subroutine psi_dgthzv(n,idx,x,y) end subroutine psi_dgthzv +subroutine psi_dsctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + real(psb_dpk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == dzero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == done) 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_dsctmm + subroutine psi_dsctmv(n,k,idx,x,beta,y) use psb_const_mod diff --git a/base/serial/psi_i_serial_impl.f90 b/base/serial/psi_i_serial_impl.f90 index 284f8c97..c5113eef 100644 --- a/base/serial/psi_i_serial_impl.f90 +++ b/base/serial/psi_i_serial_impl.f90 @@ -249,6 +249,24 @@ subroutine psi_igthv(n,idx,alpha,x,beta,y) end subroutine psi_igthv +subroutine psi_igthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_ipk_) :: 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_igthzmm + subroutine psi_igthzmv(n,k,idx,x,y) use psb_const_mod @@ -287,6 +305,32 @@ subroutine psi_igthzv(n,idx,x,y) end subroutine psi_igthzv +subroutine psi_isctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_ipk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == izero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == ione) 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_isctmm + subroutine psi_isctmv(n,k,idx,x,beta,y) use psb_const_mod diff --git a/base/serial/psi_s_serial_impl.f90 b/base/serial/psi_s_serial_impl.f90 index 6137308b..1687405b 100644 --- a/base/serial/psi_s_serial_impl.f90 +++ b/base/serial/psi_s_serial_impl.f90 @@ -249,6 +249,24 @@ subroutine psi_sgthv(n,idx,alpha,x,beta,y) end subroutine psi_sgthv +subroutine psi_sgthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + real(psb_spk_) :: 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_sgthzmm + subroutine psi_sgthzmv(n,k,idx,x,y) use psb_const_mod @@ -287,6 +305,32 @@ subroutine psi_sgthzv(n,idx,x,y) end subroutine psi_sgthzv +subroutine psi_ssctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + real(psb_spk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == szero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == sone) 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_ssctmm + subroutine psi_ssctmv(n,k,idx,x,beta,y) use psb_const_mod diff --git a/base/serial/psi_z_serial_impl.f90 b/base/serial/psi_z_serial_impl.f90 index 6b4c44ee..791b4f05 100644 --- a/base/serial/psi_z_serial_impl.f90 +++ b/base/serial/psi_z_serial_impl.f90 @@ -249,6 +249,24 @@ subroutine psi_zgthv(n,idx,alpha,x,beta,y) end subroutine psi_zgthv +subroutine psi_zgthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_dpk_) :: 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_zgthzmm + subroutine psi_zgthzmv(n,k,idx,x,y) use psb_const_mod @@ -287,6 +305,32 @@ subroutine psi_zgthzv(n,idx,x,y) end subroutine psi_zgthzv +subroutine psi_zsctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + complex(psb_dpk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == zzero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == zone) 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_zsctmm + subroutine psi_zsctmv(n,k,idx,x,beta,y) use psb_const_mod