fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 04:12:09 +00:00
Code Issues Packages Projects Releases Wiki Activity

New internals for ovrl on multivectors.

Browse Source
This commit is contained in:
Salvatore Filippone
2015-07-16 18:58:10 +00:00
parent 410a52745f
commit 05929a80c5
36 changed files with 4392 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/internals/Makefile
+6 -1
View File
@@ -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
base/internals/psi_covrl_restr.f90
+200
View File
@@ -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
base/internals/psi_covrl_save.f90
+227
View File
@@ -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
base/internals/psi_covrl_upd.f90
+323
View File
@@ -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
base/internals/psi_dovrl_restr.f90
+200
View File
@@ -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
base/internals/psi_dovrl_save.f90
+227
View File
@@ -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
base/internals/psi_dovrl_upd.f90
+323
View File
@@ -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
base/internals/psi_iovrl_restr.f90
+200
View File
@@ -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
base/internals/psi_iovrl_save.f90
+227
View File
@@ -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
base/internals/psi_iovrl_upd.f90
+323
View File
@@ -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
base/internals/psi_sovrl_restr.f90
+200
View File
@@ -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
base/internals/psi_sovrl_save.f90
+227
View File
@@ -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
base/internals/psi_sovrl_upd.f90
+323
View File
@@ -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
base/internals/psi_zovrl_restr.f90
+200
View File
@@ -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
base/internals/psi_zovrl_save.f90
+227
View File
@@ -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
base/internals/psi_zovrl_upd.f90
+323
View File
@@ -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
base/modules/psb_c_base_vect_mod.f90
+43 -2
View File
@@ -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
base/modules/psb_d_base_vect_mod.f90
+43 -2
View File
@@ -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
base/modules/psb_i_base_vect_mod.f90
+43 -2
View File
@@ -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
base/modules/psb_s_base_vect_mod.f90
+43 -2
View File
@@ -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
base/modules/psb_z_base_vect_mod.f90
+43 -2
View File
@@ -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
base/modules/psi_c_mod.f90
+26 -5
View File
@@ -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
base/modules/psi_c_serial_mod.f90
+13
View File
@@ -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
base/modules/psi_d_mod.f90
+26 -5
View File
@@ -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
base/modules/psi_d_serial_mod.f90
+13
View File
@@ -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
base/modules/psi_i_mod.f90
+32 -11
View File
@@ -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
base/modules/psi_i_serial_mod.f90
+13
View File
@@ -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
base/modules/psi_s_mod.f90
+26 -5
View File
@@ -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
base/modules/psi_s_serial_mod.f90
+13
View File
@@ -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
base/modules/psi_z_mod.f90
+26 -5
View File
@@ -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
base/modules/psi_z_serial_mod.f90
+13
View File
@@ -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
base/serial/psi_c_serial_impl.f90
+44
View File
@@ -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
base/serial/psi_d_serial_impl.f90
+44
View File
@@ -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
base/serial/psi_i_serial_impl.f90
+44
View File
@@ -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
base/serial/psi_s_serial_impl.f90
+44
View File
@@ -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
base/serial/psi_z_serial_impl.f90
+44
View File
@@ -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