diff --git a/base/comm/Makefile b/base/comm/Makefile index bbe769c5..ba12bddf 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -14,16 +14,18 @@ INCDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) -lib: mpfobjs $(OBJS) +lib: interns mpfobjs $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(OBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) - +interns: + cd internals && $(MAKE) lib mpfobjs: $(MAKE) $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)" clean: + cd internals && $(MAKE) clean /bin/rm -f $(MPFOBJS) $(OBJS) veryclean: clean diff --git a/base/comm/internals/Makefile b/base/comm/internals/Makefile new file mode 100644 index 00000000..3ad38a1c --- /dev/null +++ b/base/comm/internals/Makefile @@ -0,0 +1,31 @@ +include ../../../Make.inc + +FOBJS = 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 + +MPFOBJS = psi_dswapdata.o psi_dswaptran.o\ + psi_sswapdata.o psi_sswaptran.o \ + psi_iswapdata.o psi_iswaptran.o \ + psi_cswapdata.o psi_cswaptran.o \ + psi_zswapdata.o psi_zswaptran.o +LIBDIR=../.. +INCDIR=../.. +MODDIR=../../modules +FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) +CINCLUDES=-I. + +lib: mpfobjs $(FOBJS) $(MPFOBJS) + $(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS) + $(RANLIB) $(LIBDIR)/$(LIBNAME) + +$(FOBJS) $(FBOJS2): $(MODDIR)/psi_mod.o +mpfobjs: + (make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)") + +clean: + /bin/rm -f $(MPFOBJS) $(FOBJS) $(COBJS) $(FOBJS2) $(MPFOBJS2) *$(.mod) + +veryclean: clean diff --git a/base/internals/psi_covrl_restr.f90 b/base/comm/internals/psi_covrl_restr.f90 similarity index 100% rename from base/internals/psi_covrl_restr.f90 rename to base/comm/internals/psi_covrl_restr.f90 diff --git a/base/internals/psi_covrl_save.f90 b/base/comm/internals/psi_covrl_save.f90 similarity index 100% rename from base/internals/psi_covrl_save.f90 rename to base/comm/internals/psi_covrl_save.f90 diff --git a/base/internals/psi_covrl_upd.f90 b/base/comm/internals/psi_covrl_upd.f90 similarity index 100% rename from base/internals/psi_covrl_upd.f90 rename to base/comm/internals/psi_covrl_upd.f90 diff --git a/base/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 similarity index 100% rename from base/internals/psi_cswapdata.F90 rename to base/comm/internals/psi_cswapdata.F90 diff --git a/base/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 similarity index 100% rename from base/internals/psi_cswaptran.F90 rename to base/comm/internals/psi_cswaptran.F90 diff --git a/base/internals/psi_dovrl_restr.f90 b/base/comm/internals/psi_dovrl_restr.f90 similarity index 100% rename from base/internals/psi_dovrl_restr.f90 rename to base/comm/internals/psi_dovrl_restr.f90 diff --git a/base/internals/psi_dovrl_save.f90 b/base/comm/internals/psi_dovrl_save.f90 similarity index 100% rename from base/internals/psi_dovrl_save.f90 rename to base/comm/internals/psi_dovrl_save.f90 diff --git a/base/internals/psi_dovrl_upd.f90 b/base/comm/internals/psi_dovrl_upd.f90 similarity index 100% rename from base/internals/psi_dovrl_upd.f90 rename to base/comm/internals/psi_dovrl_upd.f90 diff --git a/base/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 similarity index 100% rename from base/internals/psi_dswapdata.F90 rename to base/comm/internals/psi_dswapdata.F90 diff --git a/base/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 similarity index 100% rename from base/internals/psi_dswaptran.F90 rename to base/comm/internals/psi_dswaptran.F90 diff --git a/base/internals/psi_iovrl_restr.f90 b/base/comm/internals/psi_iovrl_restr.f90 similarity index 100% rename from base/internals/psi_iovrl_restr.f90 rename to base/comm/internals/psi_iovrl_restr.f90 diff --git a/base/internals/psi_iovrl_save.f90 b/base/comm/internals/psi_iovrl_save.f90 similarity index 100% rename from base/internals/psi_iovrl_save.f90 rename to base/comm/internals/psi_iovrl_save.f90 diff --git a/base/internals/psi_iovrl_upd.f90 b/base/comm/internals/psi_iovrl_upd.f90 similarity index 100% rename from base/internals/psi_iovrl_upd.f90 rename to base/comm/internals/psi_iovrl_upd.f90 diff --git a/base/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 similarity index 100% rename from base/internals/psi_iswapdata.F90 rename to base/comm/internals/psi_iswapdata.F90 diff --git a/base/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 similarity index 100% rename from base/internals/psi_iswaptran.F90 rename to base/comm/internals/psi_iswaptran.F90 diff --git a/base/internals/psi_sovrl_restr.f90 b/base/comm/internals/psi_sovrl_restr.f90 similarity index 100% rename from base/internals/psi_sovrl_restr.f90 rename to base/comm/internals/psi_sovrl_restr.f90 diff --git a/base/internals/psi_sovrl_save.f90 b/base/comm/internals/psi_sovrl_save.f90 similarity index 100% rename from base/internals/psi_sovrl_save.f90 rename to base/comm/internals/psi_sovrl_save.f90 diff --git a/base/internals/psi_sovrl_upd.f90 b/base/comm/internals/psi_sovrl_upd.f90 similarity index 100% rename from base/internals/psi_sovrl_upd.f90 rename to base/comm/internals/psi_sovrl_upd.f90 diff --git a/base/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 similarity index 100% rename from base/internals/psi_sswapdata.F90 rename to base/comm/internals/psi_sswapdata.F90 diff --git a/base/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 similarity index 100% rename from base/internals/psi_sswaptran.F90 rename to base/comm/internals/psi_sswaptran.F90 diff --git a/base/internals/psi_zovrl_restr.f90 b/base/comm/internals/psi_zovrl_restr.f90 similarity index 100% rename from base/internals/psi_zovrl_restr.f90 rename to base/comm/internals/psi_zovrl_restr.f90 diff --git a/base/internals/psi_zovrl_save.f90 b/base/comm/internals/psi_zovrl_save.f90 similarity index 100% rename from base/internals/psi_zovrl_save.f90 rename to base/comm/internals/psi_zovrl_save.f90 diff --git a/base/internals/psi_zovrl_upd.f90 b/base/comm/internals/psi_zovrl_upd.f90 similarity index 100% rename from base/internals/psi_zovrl_upd.f90 rename to base/comm/internals/psi_zovrl_upd.f90 diff --git a/base/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 similarity index 100% rename from base/internals/psi_zswapdata.F90 rename to base/comm/internals/psi_zswapdata.F90 diff --git a/base/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 similarity index 100% rename from base/internals/psi_zswaptran.F90 rename to base/comm/internals/psi_zswaptran.F90 diff --git a/base/internals/Makefile b/base/internals/Makefile index d656c510..1230aca1 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -5,23 +5,27 @@ 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_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_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 -MPFOBJS = psi_dswapdata.o psi_dswaptran.o\ - psi_sswapdata.o psi_sswaptran.o \ - psi_iswapdata.o psi_iswaptran.o \ - psi_cswapdata.o psi_cswaptran.o \ - psi_zswapdata.o psi_zswaptran.o \ - psi_desc_index.o psi_extrct_dl.o \ +MPFOBJS = psi_desc_index.o psi_extrct_dl.o \ psi_fnd_owner.o psb_indx_map_fnd_owner.o + +#psi_dswapdata.o psi_dswaptran.o\ +# psi_sswapdata.o psi_sswaptran.o \ +# psi_iswapdata.o psi_iswaptran.o \ +# psi_cswapdata.o psi_cswaptran.o \ +# psi_zswapdata.o psi_zswaptran.o \ + LIBDIR=.. INCDIR=.. MODDIR=../modules diff --git a/base/internals/psi_ovrl_restr.f90 b/base/internals/psi_ovrl_restr.f90 deleted file mode 100644 index a9c6a50a..00000000 --- a/base/internals/psi_ovrl_restr.f90 +++ /dev/null @@ -1,685 +0,0 @@ -!!$ -!!$ 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_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_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_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_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_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) - - 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_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_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) - - 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_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_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) - - 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_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_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) - - 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_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_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) - - 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 - - diff --git a/base/internals/psi_ovrl_save.f90 b/base/internals/psi_ovrl_save.f90 deleted file mode 100644 index 2eb5e245..00000000 --- a/base/internals/psi_ovrl_save.f90 +++ /dev/null @@ -1,760 +0,0 @@ -!!$ -!!$ 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_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_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_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_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_desc_mod - use psb_const_mod - use psb_error_mod - use psb_realloc_mod - use psb_penv_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_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 - - 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_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_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 - - 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_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_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_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 - - 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_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 diff --git a/base/internals/psi_ovrl_upd.f90 b/base/internals/psi_ovrl_upd.f90 deleted file mode 100644 index de9b46a4..00000000 --- a/base/internals/psi_ovrl_upd.f90 +++ /dev/null @@ -1,1097 +0,0 @@ -!!$ -!!$ 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_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_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_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_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) - ! Square root does not make sense here -!!$ 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) - ! Square root does not make sense here -!!$ 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_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_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(dble(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/dble(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_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) = 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,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_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(dble(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/dble(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,zzero) - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_upd_vect - -