From c573f38d348c863d1843cab089f46a8d51a44cb5 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 6 Apr 2018 16:37:00 +0100 Subject: [PATCH] Fix psi_serial_impl missing AXPBY. --- base/serial/psi_c_serial_impl.f90 | 201 ++++++++++++++++++++++++++++++ base/serial/psi_d_serial_impl.f90 | 201 ++++++++++++++++++++++++++++++ base/serial/psi_i_serial_impl.f90 | 201 ++++++++++++++++++++++++++++++ base/serial/psi_s_serial_impl.f90 | 201 ++++++++++++++++++++++++++++++ base/serial/psi_z_serial_impl.f90 | 201 ++++++++++++++++++++++++++++++ 5 files changed, 1005 insertions(+) diff --git a/base/serial/psi_c_serial_impl.f90 b/base/serial/psi_c_serial_impl.f90 index 6faa5248..4794c38e 100644 --- a/base/serial/psi_c_serial_impl.f90 +++ b/base/serial/psi_c_serial_impl.f90 @@ -1,3 +1,34 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! subroutine psi_caxpby(m,n,alpha, x, beta, y, info) use psb_const_mod @@ -394,3 +425,173 @@ subroutine psi_csctv(n,idx,x,beta,y) end do end if end subroutine psi_csctv + +subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + complex(psb_spk_) X(lldx,*), Y(lldy,*) + complex(psb_spk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='caxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.czero) then + if (beta.eq.czero) then + do j=1, n + do i=1,m + y(i,j) = czero + enddo + enddo + else if (beta.eq.cone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.cone) then + + if (beta.eq.czero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.cone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-cone) then + + if (beta.eq.czero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.cone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.czero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.cone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine caxpby diff --git a/base/serial/psi_d_serial_impl.f90 b/base/serial/psi_d_serial_impl.f90 index 87de71d4..71f62cd5 100644 --- a/base/serial/psi_d_serial_impl.f90 +++ b/base/serial/psi_d_serial_impl.f90 @@ -1,3 +1,34 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! subroutine psi_daxpby(m,n,alpha, x, beta, y, info) use psb_const_mod @@ -394,3 +425,173 @@ subroutine psi_dsctv(n,idx,x,beta,y) end do end if end subroutine psi_dsctv + +subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + real(psb_dpk_) X(lldx,*), Y(lldy,*) + real(psb_dpk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='daxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.dzero) then + if (beta.eq.dzero) then + do j=1, n + do i=1,m + y(i,j) = dzero + enddo + enddo + else if (beta.eq.done) then + ! + ! Do nothing! + ! + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.done) then + + if (beta.eq.dzero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.done) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-done) then + + if (beta.eq.dzero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.done) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.dzero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.done) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine daxpby diff --git a/base/serial/psi_i_serial_impl.f90 b/base/serial/psi_i_serial_impl.f90 index c5113eef..90d2cdea 100644 --- a/base/serial/psi_i_serial_impl.f90 +++ b/base/serial/psi_i_serial_impl.f90 @@ -1,3 +1,34 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! subroutine psi_iaxpby(m,n,alpha, x, beta, y, info) use psb_const_mod @@ -394,3 +425,173 @@ subroutine psi_isctv(n,idx,x,beta,y) end do end if end subroutine psi_isctv + +subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + integer(psb_ipk_) X(lldx,*), Y(lldy,*) + integer(psb_ipk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='iaxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.izero) then + if (beta.eq.izero) then + do j=1, n + do i=1,m + y(i,j) = izero + enddo + enddo + else if (beta.eq.ione) then + ! + ! Do nothing! + ! + + else if (beta.eq.-ione) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.ione) then + + if (beta.eq.izero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.ione) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-ione) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-ione) then + + if (beta.eq.izero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.ione) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-ione) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.izero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.ione) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-ione) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine iaxpby diff --git a/base/serial/psi_s_serial_impl.f90 b/base/serial/psi_s_serial_impl.f90 index 1687405b..cba56128 100644 --- a/base/serial/psi_s_serial_impl.f90 +++ b/base/serial/psi_s_serial_impl.f90 @@ -1,3 +1,34 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! subroutine psi_saxpby(m,n,alpha, x, beta, y, info) use psb_const_mod @@ -394,3 +425,173 @@ subroutine psi_ssctv(n,idx,x,beta,y) end do end if end subroutine psi_ssctv + +subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + real(psb_spk_) X(lldx,*), Y(lldy,*) + real(psb_spk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='saxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.szero) then + if (beta.eq.szero) then + do j=1, n + do i=1,m + y(i,j) = szero + enddo + enddo + else if (beta.eq.sone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.sone) then + + if (beta.eq.szero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-sone) then + + if (beta.eq.szero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.szero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine saxpby diff --git a/base/serial/psi_z_serial_impl.f90 b/base/serial/psi_z_serial_impl.f90 index 791b4f05..9444f6c5 100644 --- a/base/serial/psi_z_serial_impl.f90 +++ b/base/serial/psi_z_serial_impl.f90 @@ -1,3 +1,34 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) use psb_const_mod @@ -394,3 +425,173 @@ subroutine psi_zsctv(n,idx,x,beta,y) end do end if end subroutine psi_zsctv + +subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + complex(psb_dpk_) X(lldx,*), Y(lldy,*) + complex(psb_dpk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='zaxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.zzero) then + if (beta.eq.zzero) then + do j=1, n + do i=1,m + y(i,j) = zzero + enddo + enddo + else if (beta.eq.zone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.zone) then + + if (beta.eq.zzero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.zone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-zone) then + + if (beta.eq.zzero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.zone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.zzero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.zone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine zaxpby