From f184d30b0ac03c473b03c887d85569c584ae1e61 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 14 May 2008 11:36:12 +0000 Subject: [PATCH] psblas2-dev: base/modules/psb_serial_mod.f90 base/serial/Makefile base/serial/psb_dspsetbld.f90 base/serial/psb_dspshift.f90 base/serial/psb_zspscal.f90 base/serial/psb_zspsetbld.f90 base/serial/psb_zspshift.f90 Updated shift routines & moved onto complex version. --- base/modules/psb_serial_mod.f90 | 38 ++++++++ base/serial/Makefile | 2 +- base/serial/psb_dspsetbld.f90 | 152 ++++++++++++++++++++++++++++++++ base/serial/psb_dspshift.f90 | 3 +- base/serial/psb_zspscal.f90 | 59 +++++++++++++ base/serial/psb_zspsetbld.f90 | 152 ++++++++++++++++++++++++++++++++ base/serial/psb_zspshift.f90 | 91 +++++++++++++++++++ 7 files changed, 494 insertions(+), 3 deletions(-) create mode 100644 base/serial/psb_dspsetbld.f90 create mode 100644 base/serial/psb_zspsetbld.f90 create mode 100644 base/serial/psb_zspshift.f90 diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index f5d655c5..58778327 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -426,6 +426,12 @@ module psb_serial_mod real(psb_dpk_), intent(in) :: d(:) integer, intent(out) :: info end subroutine psb_dspscal + subroutine psb_zspscals(a,d,info) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer, intent(out) :: info + end subroutine psb_zspscals subroutine psb_zspscal(a,d,info) use psb_spmat_type type(psb_zspmat_type), intent(inout) :: a @@ -435,6 +441,31 @@ module psb_serial_mod end interface + interface psb_sp_setbld + subroutine psb_dspsetbld1(a,info) + use psb_spmat_type + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + end subroutine psb_dspsetbld1 + subroutine psb_dspsetbld2(a,b,info) + use psb_spmat_type + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_dspsetbld2 + subroutine psb_zspsetbld1(a,info) + use psb_spmat_type + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + end subroutine psb_zspsetbld1 + subroutine psb_zspsetbld2(a,b,info) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(out) :: b + integer, intent(out) :: info + end subroutine psb_zspsetbld2 + end interface + interface psb_sp_shift subroutine psb_dspshift(alpha,a,beta,b,info) use psb_spmat_type @@ -443,6 +474,13 @@ module psb_serial_mod real(psb_dpk_), intent(in) :: alpha, beta integer, intent(out) :: info end subroutine psb_dspshift + subroutine psb_zspshift(alpha,a,beta,b,info) + use psb_spmat_type + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(out) :: b + complex(psb_dpk_), intent(in) :: alpha, beta + integer, intent(out) :: info + end subroutine psb_zspshift end interface interface psb_sp_getblk diff --git a/base/serial/Makefile b/base/serial/Makefile index 70d1637b..8c4410dc 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -14,7 +14,7 @@ FOBJS = psb_cest.o psb_dcoins.o psb_dcsmm.o psb_dcsmv.o \ psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\ psb_getifield.o psb_setifield.o psb_update_mod.o psb_getrow_mod.o\ psb_dgelp.o psb_zgelp.o psb_dcsrp.o psb_zcsrp.o\ - psb_dspshift.o + psb_dspshift.o psb_dspsetbld.o psb_zspshift.o psb_zspsetbld.o LIBDIR=.. MODDIR=../modules diff --git a/base/serial/psb_dspsetbld.f90 b/base/serial/psb_dspsetbld.f90 new file mode 100644 index 00000000..153a208d --- /dev/null +++ b/base/serial/psb_dspsetbld.f90 @@ -0,0 +1,152 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_dspgtblk.f90 +! Subroutine: psb_dspgtblk +! Gets one or more rows from a sparse matrix. +! Arguments: +!***************************************************************************** +!* * +!* Takes a specified row from matrix A and copies into matrix B (possibly * +!* appending to B). Output is always COO. Input might be anything, * +!* * +!***************************************************************************** +subroutine psb_dspsetbld1(a,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_dspsetbld1 + + implicit none + + type(psb_dspmat_type), intent(inout) :: a + integer, intent(out) :: info + + logical :: append_,srt_ + integer :: i,j, err_act + character(len=20) :: name + + name='psb_sp_setbld' + info = 0 + call psb_erractionsave(err_act) + + select case(psb_sp_getifld(psb_state_,a,info)) + case (psb_spmat_asb_,psb_spmat_upd_) + call psb_spcnv(a,info,afmt='COO') + if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,a,info) + case (psb_spmat_bld_) + ! do nothing + + case default + info=591 + call psb_errpush(info,name) + goto 9999 + end select + + + if (info /= 0) then + call psb_errpush(4010,name,a_err='Internal call') + goto 9999 + end if + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_dspsetbld1 +subroutine psb_dspsetbld2(a,b,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_dspsetbld2 + + implicit none + + type(psb_dspmat_type), intent(in) :: a + type(psb_dspmat_type), intent(out) :: b + integer, intent(out) :: info + + logical :: append_,srt_ + integer :: i,j, err_act + character(len=20) :: name + + name='psb_sp_setbld' + info = 0 + call psb_erractionsave(err_act) + + + select case(psb_sp_getifld(psb_state_,a,info)) + case (psb_spmat_asb_,psb_spmat_upd_) + call psb_spcnv(a,b,info,afmt='COO') + if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,b,info) + + case (psb_spmat_bld_) + call psb_sp_clone(a,b,info) + + case default + info=591 + call psb_errpush(info,name) + goto 9999 + end select + + if (info /= 0) then + call psb_errpush(4010,name,a_err='Internal call') + goto 9999 + end if + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_dspsetbld2 + diff --git a/base/serial/psb_dspshift.f90 b/base/serial/psb_dspshift.f90 index 1c436ffd..bec05510 100644 --- a/base/serial/psb_dspshift.f90 +++ b/base/serial/psb_dspshift.f90 @@ -62,9 +62,8 @@ subroutine psb_dspshift(alpha,a,beta,b,info) info = 0 call psb_erractionsave(err_act) - call psb_spcnv(a,b,info,afmt='COO') + call psb_sp_setbld(a,b,info) if (info == 0) call psb_sp_scal(b,alpha,info) - call psb_sp_setifld(psb_spmat_bld_,psb_state_,b,info) do i=1,min(b%m,b%k) if (info == 0) call psb_coins(1,(/i/),(/i/),(/beta/),b,1,1,b%m,b%k,info) end do diff --git a/base/serial/psb_zspscal.f90 b/base/serial/psb_zspscal.f90 index e48c5323..9ccfad23 100644 --- a/base/serial/psb_zspscal.f90 +++ b/base/serial/psb_zspscal.f90 @@ -96,4 +96,63 @@ subroutine psb_zspscal(a,d,info) return end subroutine psb_zspscal +subroutine psb_zspscals(a,d,info) + ! the input format + use psb_spmat_type + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + complex(psb_dpk_), intent(in) :: d + + integer :: i,j, err_act + character(len=20) :: name, ch_err + + name='psb_zspscal' + info = 0 + call psb_erractionsave(err_act) + + select case(psb_toupper(a%fida(1:3))) + case ('CSR') + + do i=1, a%m + do j=a%ia2(i),a%ia2(i+1)-1 + a%aspk(j) = a%aspk(j) * d + end do + end do + + case ('COO') + + do i=1,a%infoa(psb_nnz_) + j=a%ia1(i) + a%aspk(i) = a%aspk(i) * d + enddo + + case ('JAD') + info=135 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + case default + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_zspscals diff --git a/base/serial/psb_zspsetbld.f90 b/base/serial/psb_zspsetbld.f90 new file mode 100644 index 00000000..a73830ca --- /dev/null +++ b/base/serial/psb_zspsetbld.f90 @@ -0,0 +1,152 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_zspgtblk.f90 +! Subroutine: psb_zspgtblk +! Gets one or more rows from a sparse matrix. +! Arguments: +!***************************************************************************** +!* * +!* Takes a specified row from matrix A and copies into matrix B (possibly * +!* appending to B). Output is always COO. Input might be anything, * +!* * +!***************************************************************************** +subroutine psb_zspsetbld1(a,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_zspsetbld1 + + implicit none + + type(psb_zspmat_type), intent(inout) :: a + integer, intent(out) :: info + + logical :: append_,srt_ + integer :: i,j, err_act + character(len=20) :: name + + name='psb_sp_setbld' + info = 0 + call psb_erractionsave(err_act) + + select case(psb_sp_getifld(psb_state_,a,info)) + case (psb_spmat_asb_,psb_spmat_upd_) + call psb_spcnv(a,info,afmt='COO') + if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,a,info) + case (psb_spmat_bld_) + ! do nothing + + case default + info=591 + call psb_errpush(info,name) + goto 9999 + end select + + + if (info /= 0) then + call psb_errpush(4010,name,a_err='Internal call') + goto 9999 + end if + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_zspsetbld1 +subroutine psb_zspsetbld2(a,b,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_zspsetbld2 + + implicit none + + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(out) :: b + integer, intent(out) :: info + + logical :: append_,srt_ + integer :: i,j, err_act + character(len=20) :: name + + name='psb_sp_setbld' + info = 0 + call psb_erractionsave(err_act) + + + select case(psb_sp_getifld(psb_state_,a,info)) + case (psb_spmat_asb_,psb_spmat_upd_) + call psb_spcnv(a,b,info,afmt='COO') + if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,b,info) + + case (psb_spmat_bld_) + call psb_sp_clone(a,b,info) + + case default + info=591 + call psb_errpush(info,name) + goto 9999 + end select + + if (info /= 0) then + call psb_errpush(4010,name,a_err='Internal call') + goto 9999 + end if + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_zspsetbld2 + diff --git a/base/serial/psb_zspshift.f90 b/base/serial/psb_zspshift.f90 new file mode 100644 index 00000000..71d44a72 --- /dev/null +++ b/base/serial/psb_zspshift.f90 @@ -0,0 +1,91 @@ +!!$ +!!$ Parallel Sparse BLAS version 2.2 +!!$ (C) Copyright 2006/2007/2008 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_zspgtblk.f90 +! Subroutine: psb_zspgtblk +! Gets one or more rows from a sparse matrix. +! Arguments: +!***************************************************************************** +!* * +!* Takes a specified row from matrix A and copies into matrix B (possibly * +!* appending to B). Output is always COO. Input might be anything, * +!* * +!***************************************************************************** +subroutine psb_zspshift(alpha,a,beta,b,info) + ! Output is always in COO format into B, irrespective of + ! the input format + use psb_spmat_type + use psb_const_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_zspshift + + implicit none + + type(psb_zspmat_type), intent(in) :: a + type(psb_zspmat_type), intent(out) :: b + complex(psb_dpk_), intent(in) :: alpha, beta + integer, intent(out) :: info + + logical :: append_,srt_ + integer :: i,j, err_act + character(len=20) :: name + + name='psb_sp_shift' + info = 0 + call psb_erractionsave(err_act) + + call psb_sp_setbld(a,b,info) + if (info == 0) call psb_sp_scal(b,alpha,info) + do i=1,min(b%m,b%k) + if (info == 0) call psb_coins(1,(/i/),(/i/),(/beta/),b,1,1,b%m,b%k,info) + end do + if (info == 0) call psb_spcnv(b,info,afmt=a%fida,dupl=psb_dupl_add_) + + if (info /= 0) then + call psb_errpush(4010,name,a_err='Internal call') + goto 9999 + end if + + call psb_erractionrestore(err_act) + + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + +end subroutine psb_zspshift +