From 335066b305f5af0a9b6ea80730989b89958b9d39 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 12 Mar 2018 13:09:14 +0000 Subject: [PATCH] New I/L/E/M tools (interface & impl). --- base/modules/Makefile | 13 +- base/modules/tools/psb_c_tools_a_mod.f90 | 119 ++++++++ base/modules/tools/psb_c_tools_mod.f90 | 70 ----- base/modules/tools/psb_d_tools_a_mod.f90 | 119 ++++++++ base/modules/tools/psb_d_tools_mod.f90 | 70 ----- base/modules/tools/psb_e_tools_a_mod.f90 | 119 ++++++++ base/modules/tools/psb_i_tools_mod.f90 | 70 ----- base/modules/tools/psb_l_tools_mod.f90 | 70 ----- base/modules/tools/psb_m_tools_a_mod.f90 | 119 ++++++++ base/modules/tools/psb_s_tools_a_mod.f90 | 119 ++++++++ base/modules/tools/psb_s_tools_mod.f90 | 70 ----- base/modules/tools/psb_tools_mod.f90 | 6 + base/modules/tools/psb_z_tools_a_mod.f90 | 119 ++++++++ base/modules/tools/psb_z_tools_mod.f90 | 70 ----- base/tools/Makefile | 9 +- base/tools/psb_callc.f90 | 203 ------------- base/tools/psb_callc_a.f90 | 246 +++++++++++++++ base/tools/psb_casb.f90 | 212 ------------- base/tools/psb_casb_a.f90 | 254 ++++++++++++++++ base/tools/psb_cfree.f90 | 123 -------- base/tools/psb_cfree_a.f90 | 162 ++++++++++ base/tools/psb_cins.f90 | 324 -------------------- base/tools/psb_cins_a.f90 | 371 +++++++++++++++++++++++ base/tools/psb_dallc.f90 | 203 ------------- base/tools/psb_dallc_a.f90 | 246 +++++++++++++++ base/tools/psb_dasb.f90 | 212 ------------- base/tools/psb_dasb_a.f90 | 254 ++++++++++++++++ base/tools/psb_dfree.f90 | 123 -------- base/tools/psb_dfree_a.f90 | 162 ++++++++++ base/tools/psb_dins.f90 | 324 -------------------- base/tools/psb_dins_a.f90 | 371 +++++++++++++++++++++++ base/tools/psb_eallc_a.f90 | 246 +++++++++++++++ base/tools/psb_easb_a.f90 | 254 ++++++++++++++++ base/tools/psb_efree_a.f90 | 162 ++++++++++ base/tools/psb_eins_a.f90 | 371 +++++++++++++++++++++++ base/tools/psb_iallc.f90 | 203 ------------- base/tools/psb_iasb.f90 | 212 ------------- base/tools/psb_ifree.f90 | 123 -------- base/tools/psb_iins.f90 | 324 -------------------- base/tools/psb_lallc.f90 | 203 ------------- base/tools/psb_lasb.f90 | 212 ------------- base/tools/psb_lfree.f90 | 123 -------- base/tools/psb_lins.f90 | 324 -------------------- base/tools/psb_mallc_a.f90 | 246 +++++++++++++++ base/tools/psb_masb_a.f90 | 254 ++++++++++++++++ base/tools/psb_mfree_a.f90 | 162 ++++++++++ base/tools/psb_mins_a.f90 | 371 +++++++++++++++++++++++ base/tools/psb_sallc.f90 | 203 ------------- base/tools/psb_sallc_a.f90 | 246 +++++++++++++++ base/tools/psb_sasb.f90 | 212 ------------- base/tools/psb_sasb_a.f90 | 254 ++++++++++++++++ base/tools/psb_sfree.f90 | 123 -------- base/tools/psb_sfree_a.f90 | 162 ++++++++++ base/tools/psb_sins.f90 | 324 -------------------- base/tools/psb_sins_a.f90 | 371 +++++++++++++++++++++++ base/tools/psb_zallc.f90 | 203 ------------- base/tools/psb_zallc_a.f90 | 246 +++++++++++++++ base/tools/psb_zasb.f90 | 212 ------------- base/tools/psb_zasb_a.f90 | 254 ++++++++++++++++ base/tools/psb_zfree.f90 | 123 -------- base/tools/psb_zfree_a.f90 | 162 ++++++++++ base/tools/psb_zins.f90 | 324 -------------------- base/tools/psb_zins_a.f90 | 371 +++++++++++++++++++++++ 63 files changed, 6937 insertions(+), 5595 deletions(-) create mode 100644 base/modules/tools/psb_c_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_d_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_e_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_m_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_s_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_z_tools_a_mod.f90 create mode 100644 base/tools/psb_callc_a.f90 create mode 100644 base/tools/psb_casb_a.f90 create mode 100644 base/tools/psb_cfree_a.f90 create mode 100644 base/tools/psb_cins_a.f90 create mode 100644 base/tools/psb_dallc_a.f90 create mode 100644 base/tools/psb_dasb_a.f90 create mode 100644 base/tools/psb_dfree_a.f90 create mode 100644 base/tools/psb_dins_a.f90 create mode 100644 base/tools/psb_eallc_a.f90 create mode 100644 base/tools/psb_easb_a.f90 create mode 100644 base/tools/psb_efree_a.f90 create mode 100644 base/tools/psb_eins_a.f90 create mode 100644 base/tools/psb_mallc_a.f90 create mode 100644 base/tools/psb_masb_a.f90 create mode 100644 base/tools/psb_mfree_a.f90 create mode 100644 base/tools/psb_mins_a.f90 create mode 100644 base/tools/psb_sallc_a.f90 create mode 100644 base/tools/psb_sasb_a.f90 create mode 100644 base/tools/psb_sfree_a.f90 create mode 100644 base/tools/psb_sins_a.f90 create mode 100644 base/tools/psb_zallc_a.f90 create mode 100644 base/tools/psb_zasb_a.f90 create mode 100644 base/tools/psb_zfree_a.f90 create mode 100644 base/tools/psb_zins_a.f90 diff --git a/base/modules/Makefile b/base/modules/Makefile index c4da70443..a81b040a9 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -34,6 +34,9 @@ UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_m tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ + tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ + tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ + tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o \ tools/psb_tools_mod.o \ psb_penv_mod.o $(COMMINT) psb_error_impl.o \ comm/psb_base_linmap_mod.o comm/psb_linmap_mod.o \ @@ -294,11 +297,17 @@ comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o: desc/psb_desc_mod.o tools/psb_tools_mod.o: tools/psb_cd_tools_mod.o tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ - tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o + tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ + tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ + tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ + tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o + tools/psb_cd_tools_mod.o tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o \ -tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o: desc/psb_desc_mod.o psi_mod.o serial/psb_mat_mod.o +tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ +tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ +tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o: desc/psb_desc_mod.o psi_mod.o serial/psb_mat_mod.o tools/psb_i_tools_mod.o: serial/psb_i_vect_mod.o tools/psb_l_tools_mod.o: serial/psb_l_vect_mod.o diff --git a/base/modules/tools/psb_c_tools_a_mod.f90 b/base/modules/tools/psb_c_tools_a_mod.f90 new file mode 100644 index 000000000..20f8eb54f --- /dev/null +++ b/base/modules/tools/psb_c_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! 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. +! +! +Module psb_c_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_calloc(x, desc_a, info, n, lb) + import + implicit none + complex(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_calloc + subroutine psb_callocv(x, desc_a,info,n) + import + implicit none + complex(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_callocv + end interface + + + interface psb_geasb + subroutine psb_casb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_casb + subroutine psb_casbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_casbv + end interface + + interface psb_gefree + subroutine psb_cfree(x, desc_a, info) + import + implicit none + complex(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cfree + subroutine psb_cfreev(x, desc_a, info) + import + implicit none + complex(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cfreev + end interface + + + interface psb_geins + subroutine psb_cinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_),intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_cinsi + subroutine psb_cinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_cinsvi + end interface + +end module psb_c_tools_a_mod diff --git a/base/modules/tools/psb_c_tools_mod.f90 b/base/modules/tools/psb_c_tools_mod.f90 index cda6b1a3a..42f4461fa 100644 --- a/base/modules/tools/psb_c_tools_mod.f90 +++ b/base/modules/tools/psb_c_tools_mod.f90 @@ -36,22 +36,6 @@ Module psb_c_tools_mod use psb_c_multivect_mod, only : psb_c_base_multivect_type, psb_c_multivect_type interface psb_geall - subroutine psb_calloc(x, desc_a, info, n, lb) - import - implicit none - complex(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_calloc - subroutine psb_callocv(x, desc_a,info,n) - import - implicit none - complex(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_callocv subroutine psb_calloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +64,6 @@ Module psb_c_tools_mod interface psb_geasb - subroutine psb_casb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_casb - subroutine psb_casbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_casbv subroutine psb_casb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +95,6 @@ Module psb_c_tools_mod end interface interface psb_gefree - subroutine psb_cfree(x, desc_a, info) - import - implicit none - complex(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_cfree - subroutine psb_cfreev(x, desc_a, info) - import - implicit none - complex(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_cfreev subroutine psb_cfree_vect(x, desc_a, info) import implicit none @@ -166,30 +120,6 @@ Module psb_c_tools_mod interface psb_geins - subroutine psb_cinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_cinsi - subroutine psb_cinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_cinsvi subroutine psb_cins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none diff --git a/base/modules/tools/psb_d_tools_a_mod.f90 b/base/modules/tools/psb_d_tools_a_mod.f90 new file mode 100644 index 000000000..93a7154f0 --- /dev/null +++ b/base/modules/tools/psb_d_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! 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. +! +! +Module psb_d_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_dalloc(x, desc_a, info, n, lb) + import + implicit none + real(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_dalloc + subroutine psb_dallocv(x, desc_a,info,n) + import + implicit none + real(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_dallocv + end interface + + + interface psb_geasb + subroutine psb_dasb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_dasb + subroutine psb_dasbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_dasbv + end interface + + interface psb_gefree + subroutine psb_dfree(x, desc_a, info) + import + implicit none + real(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dfree + subroutine psb_dfreev(x, desc_a, info) + import + implicit none + real(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dfreev + end interface + + + interface psb_geins + subroutine psb_dinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_),intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_dinsi + subroutine psb_dinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_dinsvi + end interface + +end module psb_d_tools_a_mod diff --git a/base/modules/tools/psb_d_tools_mod.f90 b/base/modules/tools/psb_d_tools_mod.f90 index 95c2314c0..5d12ba226 100644 --- a/base/modules/tools/psb_d_tools_mod.f90 +++ b/base/modules/tools/psb_d_tools_mod.f90 @@ -36,22 +36,6 @@ Module psb_d_tools_mod use psb_d_multivect_mod, only : psb_d_base_multivect_type, psb_d_multivect_type interface psb_geall - subroutine psb_dalloc(x, desc_a, info, n, lb) - import - implicit none - real(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_dalloc - subroutine psb_dallocv(x, desc_a,info,n) - import - implicit none - real(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_dallocv subroutine psb_dalloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +64,6 @@ Module psb_d_tools_mod interface psb_geasb - subroutine psb_dasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_dasb - subroutine psb_dasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_dasbv subroutine psb_dasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +95,6 @@ Module psb_d_tools_mod end interface interface psb_gefree - subroutine psb_dfree(x, desc_a, info) - import - implicit none - real(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_dfree - subroutine psb_dfreev(x, desc_a, info) - import - implicit none - real(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_dfreev subroutine psb_dfree_vect(x, desc_a, info) import implicit none @@ -166,30 +120,6 @@ Module psb_d_tools_mod interface psb_geins - subroutine psb_dinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_dinsi - subroutine psb_dinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_dinsvi subroutine psb_dins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none diff --git a/base/modules/tools/psb_e_tools_a_mod.f90 b/base/modules/tools/psb_e_tools_a_mod.f90 new file mode 100644 index 000000000..aa126621d --- /dev/null +++ b/base/modules/tools/psb_e_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! 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. +! +! +Module psb_e_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_epk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_ealloc(x, desc_a, info, n, lb) + import + implicit none + integer(psb_epk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_ealloc + subroutine psb_eallocv(x, desc_a,info,n) + import + implicit none + integer(psb_epk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_eallocv + end interface + + + interface psb_geasb + subroutine psb_easb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_easb + subroutine psb_easbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_easbv + end interface + + interface psb_gefree + subroutine psb_efree(x, desc_a, info) + import + implicit none + integer(psb_epk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_efree + subroutine psb_efreev(x, desc_a, info) + import + implicit none + integer(psb_epk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_efreev + end interface + + + interface psb_geins + subroutine psb_einsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_),intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_einsi + subroutine psb_einsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_einsvi + end interface + +end module psb_e_tools_a_mod diff --git a/base/modules/tools/psb_i_tools_mod.f90 b/base/modules/tools/psb_i_tools_mod.f90 index db1521b64..3e8d17c77 100644 --- a/base/modules/tools/psb_i_tools_mod.f90 +++ b/base/modules/tools/psb_i_tools_mod.f90 @@ -35,22 +35,6 @@ Module psb_i_tools_mod use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type interface psb_geall - subroutine psb_ialloc(x, desc_a, info, n, lb) - import - implicit none - integer(psb_ipk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_ialloc - subroutine psb_iallocv(x, desc_a,info,n) - import - implicit none - integer(psb_ipk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_iallocv subroutine psb_ialloc_vect(x, desc_a,info,n) import implicit none @@ -79,22 +63,6 @@ Module psb_i_tools_mod interface psb_geasb - subroutine psb_iasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_iasb - subroutine psb_iasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_iasbv subroutine psb_iasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -126,20 +94,6 @@ Module psb_i_tools_mod end interface interface psb_gefree - subroutine psb_ifree(x, desc_a, info) - import - implicit none - integer(psb_ipk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ifree - subroutine psb_ifreev(x, desc_a, info) - import - implicit none - integer(psb_ipk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ifreev subroutine psb_ifree_vect(x, desc_a, info) import implicit none @@ -165,30 +119,6 @@ Module psb_i_tools_mod interface psb_geins - subroutine psb_iinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_iinsi - subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_iinsvi subroutine psb_iins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none diff --git a/base/modules/tools/psb_l_tools_mod.f90 b/base/modules/tools/psb_l_tools_mod.f90 index 2ce79d13e..54f860180 100644 --- a/base/modules/tools/psb_l_tools_mod.f90 +++ b/base/modules/tools/psb_l_tools_mod.f90 @@ -35,22 +35,6 @@ Module psb_l_tools_mod use psb_l_multivect_mod, only : psb_l_base_multivect_type, psb_l_multivect_type interface psb_geall - subroutine psb_lalloc(x, desc_a, info, n, lb) - import - implicit none - integer(psb_lpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_lalloc - subroutine psb_lallocv(x, desc_a,info,n) - import - implicit none - integer(psb_lpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_lallocv subroutine psb_lalloc_vect(x, desc_a,info,n) import implicit none @@ -79,22 +63,6 @@ Module psb_l_tools_mod interface psb_geasb - subroutine psb_lasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_lpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_lasb - subroutine psb_lasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_lpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_lasbv subroutine psb_lasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -126,20 +94,6 @@ Module psb_l_tools_mod end interface interface psb_gefree - subroutine psb_lfree(x, desc_a, info) - import - implicit none - integer(psb_lpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lfree - subroutine psb_lfreev(x, desc_a, info) - import - implicit none - integer(psb_lpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_lfreev subroutine psb_lfree_vect(x, desc_a, info) import implicit none @@ -165,30 +119,6 @@ Module psb_l_tools_mod interface psb_geins - subroutine psb_linsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - integer(psb_lpk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_lpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_linsi - subroutine psb_linsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - integer(psb_lpk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_lpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_linsvi subroutine psb_lins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none diff --git a/base/modules/tools/psb_m_tools_a_mod.f90 b/base/modules/tools/psb_m_tools_a_mod.f90 new file mode 100644 index 000000000..a55483248 --- /dev/null +++ b/base/modules/tools/psb_m_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! 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. +! +! +Module psb_m_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_malloc(x, desc_a, info, n, lb) + import + implicit none + integer(psb_mpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_malloc + subroutine psb_mallocv(x, desc_a,info,n) + import + implicit none + integer(psb_mpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_mallocv + end interface + + + interface psb_geasb + subroutine psb_masb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_masb + subroutine psb_masbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_masbv + end interface + + interface psb_gefree + subroutine psb_mfree(x, desc_a, info) + import + implicit none + integer(psb_mpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_mfree + subroutine psb_mfreev(x, desc_a, info) + import + implicit none + integer(psb_mpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_mfreev + end interface + + + interface psb_geins + subroutine psb_minsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_),intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_minsi + subroutine psb_minsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_minsvi + end interface + +end module psb_m_tools_a_mod diff --git a/base/modules/tools/psb_s_tools_a_mod.f90 b/base/modules/tools/psb_s_tools_a_mod.f90 new file mode 100644 index 000000000..bf047164d --- /dev/null +++ b/base/modules/tools/psb_s_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! 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. +! +! +Module psb_s_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_salloc(x, desc_a, info, n, lb) + import + implicit none + real(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_salloc + subroutine psb_sallocv(x, desc_a,info,n) + import + implicit none + real(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_sallocv + end interface + + + interface psb_geasb + subroutine psb_sasb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_sasb + subroutine psb_sasbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_sasbv + end interface + + interface psb_gefree + subroutine psb_sfree(x, desc_a, info) + import + implicit none + real(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sfree + subroutine psb_sfreev(x, desc_a, info) + import + implicit none + real(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sfreev + end interface + + + interface psb_geins + subroutine psb_sinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_),intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_sinsi + subroutine psb_sinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_sinsvi + end interface + +end module psb_s_tools_a_mod diff --git a/base/modules/tools/psb_s_tools_mod.f90 b/base/modules/tools/psb_s_tools_mod.f90 index 77b7e9a97..ed49e2039 100644 --- a/base/modules/tools/psb_s_tools_mod.f90 +++ b/base/modules/tools/psb_s_tools_mod.f90 @@ -36,22 +36,6 @@ Module psb_s_tools_mod use psb_s_multivect_mod, only : psb_s_base_multivect_type, psb_s_multivect_type interface psb_geall - subroutine psb_salloc(x, desc_a, info, n, lb) - import - implicit none - real(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_salloc - subroutine psb_sallocv(x, desc_a,info,n) - import - implicit none - real(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_sallocv subroutine psb_salloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +64,6 @@ Module psb_s_tools_mod interface psb_geasb - subroutine psb_sasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_sasb - subroutine psb_sasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_sasbv subroutine psb_sasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +95,6 @@ Module psb_s_tools_mod end interface interface psb_gefree - subroutine psb_sfree(x, desc_a, info) - import - implicit none - real(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_sfree - subroutine psb_sfreev(x, desc_a, info) - import - implicit none - real(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_sfreev subroutine psb_sfree_vect(x, desc_a, info) import implicit none @@ -166,30 +120,6 @@ Module psb_s_tools_mod interface psb_geins - subroutine psb_sinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_sinsi - subroutine psb_sinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_sinsvi subroutine psb_sins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none diff --git a/base/modules/tools/psb_tools_mod.f90 b/base/modules/tools/psb_tools_mod.f90 index c8e9e782c..7f87ee794 100644 --- a/base/modules/tools/psb_tools_mod.f90 +++ b/base/modules/tools/psb_tools_mod.f90 @@ -31,6 +31,12 @@ ! module psb_tools_mod use psb_cd_tools_mod + use psb_e_tools_a_mod + use psb_m_tools_a_mod + use psb_s_tools_a_mod + use psb_d_tools_a_mod + use psb_c_tools_a_mod + use psb_z_tools_a_mod use psb_i_tools_mod use psb_l_tools_mod use psb_s_tools_mod diff --git a/base/modules/tools/psb_z_tools_a_mod.f90 b/base/modules/tools/psb_z_tools_a_mod.f90 new file mode 100644 index 000000000..905de21f8 --- /dev/null +++ b/base/modules/tools/psb_z_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! 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. +! +! +Module psb_z_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_zalloc(x, desc_a, info, n, lb) + import + implicit none + complex(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_zalloc + subroutine psb_zallocv(x, desc_a,info,n) + import + implicit none + complex(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_zallocv + end interface + + + interface psb_geasb + subroutine psb_zasb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_zasb + subroutine psb_zasbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_zasbv + end interface + + interface psb_gefree + subroutine psb_zfree(x, desc_a, info) + import + implicit none + complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zfree + subroutine psb_zfreev(x, desc_a, info) + import + implicit none + complex(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zfreev + end interface + + + interface psb_geins + subroutine psb_zinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_),intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_zinsi + subroutine psb_zinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_zinsvi + end interface + +end module psb_z_tools_a_mod diff --git a/base/modules/tools/psb_z_tools_mod.f90 b/base/modules/tools/psb_z_tools_mod.f90 index 1fd7d1bdf..cdf19d121 100644 --- a/base/modules/tools/psb_z_tools_mod.f90 +++ b/base/modules/tools/psb_z_tools_mod.f90 @@ -36,22 +36,6 @@ Module psb_z_tools_mod use psb_z_multivect_mod, only : psb_z_base_multivect_type, psb_z_multivect_type interface psb_geall - subroutine psb_zalloc(x, desc_a, info, n, lb) - import - implicit none - complex(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_zalloc - subroutine psb_zallocv(x, desc_a,info,n) - import - implicit none - complex(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_zallocv subroutine psb_zalloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +64,6 @@ Module psb_z_tools_mod interface psb_geasb - subroutine psb_zasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_zasb - subroutine psb_zasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_zasbv subroutine psb_zasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +95,6 @@ Module psb_z_tools_mod end interface interface psb_gefree - subroutine psb_zfree(x, desc_a, info) - import - implicit none - complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_zfree - subroutine psb_zfreev(x, desc_a, info) - import - implicit none - complex(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_zfreev subroutine psb_zfree_vect(x, desc_a, info) import implicit none @@ -166,30 +120,6 @@ Module psb_z_tools_mod interface psb_geins - subroutine psb_zinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_zinsi - subroutine psb_zinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_zinsvi subroutine psb_zins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none diff --git a/base/tools/Makefile b/base/tools/Makefile index a033a2cb9..029644c41 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -9,13 +9,20 @@ FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt psb_sspfree.o psb_sspins.o psb_ssprn.o\ psb_glob_to_loc.o psb_loc_to_glob.o\ psb_iallc.o psb_iasb.o psb_ifree.o psb_iins.o \ + psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \ psb_sallc.o psb_sasb.o psb_sfree.o psb_sins.o \ psb_dallc.o psb_dasb.o psb_dfree.o psb_dins.o \ + psb_callc.o psb_casb.o psb_cfree.o psb_cins.o \ psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \ + psb_mallc_a.o psb_masb_a.o psb_mfree_a.o psb_mins_a.o \ + psb_eallc_a.o psb_easb_a.o psb_efree_a.o psb_eins_a.o \ + psb_sallc_a.o psb_sasb_a.o psb_sfree_a.o psb_sins_a.o \ + psb_dallc_a.o psb_dasb_a.o psb_dfree_a.o psb_dins_a.o \ + psb_callc_a.o psb_casb_a.o psb_cfree_a.o psb_cins_a.o \ + psb_zallc_a.o psb_zasb_a.o psb_zfree_a.o psb_zins_a.o \ psb_zspalloc.o psb_zspasb.o psb_zspfree.o\ psb_zspins.o psb_zsprn.o \ psb_cspalloc.o psb_cspasb.o psb_cspfree.o\ - psb_callc.o psb_casb.o psb_cfree.o psb_cins.o \ psb_cspins.o psb_csprn.o psb_cd_set_bld.o \ psb_s_map.o psb_d_map.o psb_c_map.o psb_z_map.o # psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \ diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index a71c61b61..5b58a35ac 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_calloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_calloc - use psi_mod - implicit none - - !....parameters... - complex(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - 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 - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') - goto 9999 - endif - - x(:,:) = czero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_calloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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. -!!$ -!!$ -! -! Function: psb_callocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_callocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_callocv - use psi_mod - implicit none - - !....parameters... - complex(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') - goto 9999 - endif - - x(:) = czero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_callocv - - subroutine psb_calloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_calloc_vect use psi_mod diff --git a/base/tools/psb_callc_a.f90 b/base/tools/psb_callc_a.f90 new file mode 100644 index 000000000..1c6d3befb --- /dev/null +++ b/base/tools/psb_callc_a.f90 @@ -0,0 +1,246 @@ +! +! 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. +! +! +! +! File: psb_callc.f90 +! +! Function: psb_calloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_calloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_calloc + use psi_mod + implicit none + + !....parameters... + complex(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: np,me,err,nr,i,j,err_act + integer(psb_ipk_) :: ictxt,n_ + integer(psb_ipk_) :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + err=0 + int_err(1)=0 + 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 + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') + goto 9999 + endif + + x(:,:) = czero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_calloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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. +!!$ +!!$ +! +! Function: psb_callocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_callocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_callocv + use psi_mod + implicit none + + !....parameters... + complex(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') + goto 9999 + endif + + x(:) = czero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_callocv + diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index bb43ea3b5..a62c88b24 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - complex, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_casb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_casb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_cgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_casb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_casb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - complex, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_casbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_casbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_cgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_casbv - - subroutine psb_casb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_casb_vect implicit none diff --git a/base/tools/psb_casb_a.f90 b/base/tools/psb_casb_a.f90 new file mode 100644 index 000000000..35ffe4bf2 --- /dev/null +++ b/base/tools/psb_casb_a.f90 @@ -0,0 +1,254 @@ +! +! 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. +! +! +! File: psb_casb.f90 +! +! Subroutine: psb_casb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_casb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_casb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_cgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_casb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_casb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_casbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_casbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + int_err(1) = 0 + name = 'psb_cgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_casbv diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index f35f13f42..2d38887a3 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - complex, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_cfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_cfree - implicit none - - !....parameters... - complex(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_cfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cfree - - - -! Subroutine: psb_cfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - complex, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_cfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_cfreev - implicit none - !....parameters... - complex(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_cfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - 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 (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cfreev - subroutine psb_cfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_cfree_vect implicit none diff --git a/base/tools/psb_cfree_a.f90 b/base/tools/psb_cfree_a.f90 new file mode 100644 index 000000000..49ab1810e --- /dev/null +++ b/base/tools/psb_cfree_a.f90 @@ -0,0 +1,162 @@ +! +! 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. +! +! +! File: psb_cfree.f90 +! +! Subroutine: psb_cfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_cfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_cfree + implicit none + + !....parameters... + complex(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_cfree' + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cfree + + + +! Subroutine: psb_cfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_cfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_cfreev + implicit none + !....parameters... + complex(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_cfreev' + + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + 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 (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cfreev diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index 9bdb70bc9..a7d86c994 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_cinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:) - complex(psb_spk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_cinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cinsvi - - subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_cins_vect use psi_mod @@ -523,197 +390,6 @@ end subroutine psb_cins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_cinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - complex The source dense submatrix. -! x(:,:) - complex The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_cinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:,:) - complex(psb_spk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_cinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cinsi - - - subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_cins_multivect use psi_mod diff --git a/base/tools/psb_cins_a.f90 b/base/tools/psb_cins_a.f90 new file mode 100644 index 000000000..e22abc064 --- /dev/null +++ b/base/tools/psb_cins_a.f90 @@ -0,0 +1,371 @@ +! +! 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: psb_cinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - complex The source dense submatrix. +! x(:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_cinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_cinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - complex The source dense submatrix. +! x(:,:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_cinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + complex(psb_spk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cinsi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cinsi + diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 6b6d2078f..5bc4de55d 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_dalloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_dalloc - use psi_mod - implicit none - - !....parameters... - real(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - 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 - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') - goto 9999 - endif - - x(:,:) = dzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dalloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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. -!!$ -!!$ -! -! Function: psb_dallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_dallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_dallocv - use psi_mod - implicit none - - !....parameters... - real(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') - goto 9999 - endif - - x(:) = dzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dallocv - - subroutine psb_dalloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_dalloc_vect use psi_mod diff --git a/base/tools/psb_dallc_a.f90 b/base/tools/psb_dallc_a.f90 new file mode 100644 index 000000000..e294a3378 --- /dev/null +++ b/base/tools/psb_dallc_a.f90 @@ -0,0 +1,246 @@ +! +! 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. +! +! +! +! File: psb_dallc.f90 +! +! Function: psb_dalloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_dalloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_dalloc + use psi_mod + implicit none + + !....parameters... + real(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: np,me,err,nr,i,j,err_act + integer(psb_ipk_) :: ictxt,n_ + integer(psb_ipk_) :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + err=0 + int_err(1)=0 + 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 + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') + goto 9999 + endif + + x(:,:) = dzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dalloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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. +!!$ +!!$ +! +! Function: psb_dallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_dallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_dallocv + use psi_mod + implicit none + + !....parameters... + real(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') + goto 9999 + endif + + x(:) = dzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dallocv + diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 4e673c16c..dedcfa78d 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - real, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_dasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_dasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_dgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_dasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - real, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_dasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_dasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_dgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dasbv - - subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_dasb_vect implicit none diff --git a/base/tools/psb_dasb_a.f90 b/base/tools/psb_dasb_a.f90 new file mode 100644 index 000000000..ebb47158f --- /dev/null +++ b/base/tools/psb_dasb_a.f90 @@ -0,0 +1,254 @@ +! +! 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. +! +! +! File: psb_dasb.f90 +! +! Subroutine: psb_dasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_dasb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_dasb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_dgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dasb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_dasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_dasbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_dasbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + int_err(1) = 0 + name = 'psb_dgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dasbv diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 0c366394c..6c36dd097 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - real, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_dfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_dfree - implicit none - - !....parameters... - real(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_dfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dfree - - - -! Subroutine: psb_dfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - real, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_dfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_dfreev - implicit none - !....parameters... - real(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_dfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - 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 (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dfreev - subroutine psb_dfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_dfree_vect implicit none diff --git a/base/tools/psb_dfree_a.f90 b/base/tools/psb_dfree_a.f90 new file mode 100644 index 000000000..9ba912f6b --- /dev/null +++ b/base/tools/psb_dfree_a.f90 @@ -0,0 +1,162 @@ +! +! 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. +! +! +! File: psb_dfree.f90 +! +! Subroutine: psb_dfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_dfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_dfree + implicit none + + !....parameters... + real(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_dfree' + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dfree + + + +! Subroutine: psb_dfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_dfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_dfreev + implicit none + !....parameters... + real(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_dfreev' + + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + 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 (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dfreev diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 8c606b8d6..b2140438f 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_dinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:) - real(psb_dpk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_dinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dinsvi - - subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_dins_vect use psi_mod @@ -523,197 +390,6 @@ end subroutine psb_dins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_dinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - real The source dense submatrix. -! x(:,:) - real The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_dinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:,:) - real(psb_dpk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_dinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dinsi - - - subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_dins_multivect use psi_mod diff --git a/base/tools/psb_dins_a.f90 b/base/tools/psb_dins_a.f90 new file mode 100644 index 000000000..3a6faeb89 --- /dev/null +++ b/base/tools/psb_dins_a.f90 @@ -0,0 +1,371 @@ +! +! 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: psb_dinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - real The source dense submatrix. +! x(:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_dinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_dinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_dinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - real The source dense submatrix. +! x(:,:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_dinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:,:) + real(psb_dpk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_dinsi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dinsi + diff --git a/base/tools/psb_eallc_a.f90 b/base/tools/psb_eallc_a.f90 new file mode 100644 index 000000000..4cbec2e73 --- /dev/null +++ b/base/tools/psb_eallc_a.f90 @@ -0,0 +1,246 @@ +! +! 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. +! +! +! +! File: psb_eallc.f90 +! +! Function: psb_ealloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_ealloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_ealloc + use psi_mod + implicit none + + !....parameters... + integer(psb_epk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: np,me,err,nr,i,j,err_act + integer(psb_ipk_) :: ictxt,n_ + integer(psb_ipk_) :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + err=0 + int_err(1)=0 + 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 + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='integer(psb_epk_)') + goto 9999 + endif + + x(:,:) = ezero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ealloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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. +!!$ +!!$ +! +! Function: psb_eallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_eallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_eallocv + use psi_mod + implicit none + + !....parameters... + integer(psb_epk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='integer(psb_epk_)') + goto 9999 + endif + + x(:) = ezero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_eallocv + diff --git a/base/tools/psb_easb_a.f90 b/base/tools/psb_easb_a.f90 new file mode 100644 index 000000000..340a7c0d7 --- /dev/null +++ b/base/tools/psb_easb_a.f90 @@ -0,0 +1,254 @@ +! +! 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. +! +! +! File: psb_easb.f90 +! +! Subroutine: psb_easb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_easb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_easb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_egeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_easb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_easb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_easbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_easbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + int_err(1) = 0 + name = 'psb_egeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_easbv diff --git a/base/tools/psb_efree_a.f90 b/base/tools/psb_efree_a.f90 new file mode 100644 index 000000000..4047a3b38 --- /dev/null +++ b/base/tools/psb_efree_a.f90 @@ -0,0 +1,162 @@ +! +! 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. +! +! +! File: psb_efree.f90 +! +! Subroutine: psb_efree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_efree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_efree + implicit none + + !....parameters... + integer(psb_epk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_efree' + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_efree + + + +! Subroutine: psb_efreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_efreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_efreev + implicit none + !....parameters... + integer(psb_epk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_efreev' + + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + 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 (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_efreev diff --git a/base/tools/psb_eins_a.f90 b/base/tools/psb_eins_a.f90 new file mode 100644 index 000000000..2e84c8325 --- /dev/null +++ b/base/tools/psb_eins_a.f90 @@ -0,0 +1,371 @@ +! +! 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: psb_einsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - integer The source dense submatrix. +! x(:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_einsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_einsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:) + integer(psb_epk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_einsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_einsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_einsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - integer The source dense submatrix. +! x(:,:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_einsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_einsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:,:) + integer(psb_epk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_einsi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_einsi + diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index d9edf8b11..95e67ca1b 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_ialloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_ialloc - use psi_mod - implicit none - - !....parameters... - integer(psb_ipk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - 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 - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)') - goto 9999 - endif - - x(:,:) = izero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_ialloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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. -!!$ -!!$ -! -! Function: psb_iallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_iallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_iallocv - use psi_mod - implicit none - - !....parameters... - integer(psb_ipk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)') - goto 9999 - endif - - x(:) = izero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iallocv - - subroutine psb_ialloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_ialloc_vect use psi_mod diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 148b011ae..fc73d1a52 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - integer, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_iasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_iasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_igeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_iasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - integer, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_iasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_iasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_igeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iasbv - - subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_iasb_vect implicit none diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index 65dfa3f8f..516f1219f 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - integer, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_ifree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_ifree - implicit none - - !....parameters... - integer(psb_ipk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_ifree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_ifree - - - -! Subroutine: psb_ifreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - integer, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_ifreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_ifreev - implicit none - !....parameters... - integer(psb_ipk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_ifreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - 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 (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_ifreev - subroutine psb_ifree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_ifree_vect implicit none diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index f98e27005..e8c2dbb03 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_iinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_iinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iinsvi - - subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_iins_vect use psi_mod @@ -523,197 +390,6 @@ end subroutine psb_iins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_iinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - integer The source dense submatrix. -! x(:,:) - integer The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_iinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_iinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iinsi - - - subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_iins_multivect use psi_mod diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 index 32e9f843c..6a0be2957 100644 --- a/base/tools/psb_lallc.f90 +++ b/base/tools/psb_lallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_lalloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_lalloc - use psi_mod - implicit none - - !....parameters... - integer(psb_lpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - 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 - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='integer(psb_lpk_)') - goto 9999 - endif - - x(:,:) = lzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_lalloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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. -!!$ -!!$ -! -! Function: psb_lallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_lallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_lallocv - use psi_mod - implicit none - - !....parameters... - integer(psb_lpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='integer(psb_lpk_)') - goto 9999 - endif - - x(:) = lzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_lallocv - - subroutine psb_lalloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_lalloc_vect use psi_mod diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 index 071e27be4..515c5b331 100644 --- a/base/tools/psb_lasb.f90 +++ b/base/tools/psb_lasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - integer, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_lasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_lasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - integer(psb_lpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_lgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_lasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_lasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - integer, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_lasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_lasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - integer(psb_lpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_lgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_lasbv - - subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_lasb_vect implicit none diff --git a/base/tools/psb_lfree.f90 b/base/tools/psb_lfree.f90 index 8f51ad6ab..d6c597a80 100644 --- a/base/tools/psb_lfree.f90 +++ b/base/tools/psb_lfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - integer, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_lfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_lfree - implicit none - - !....parameters... - integer(psb_lpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_lfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_lfree - - - -! Subroutine: psb_lfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - integer, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_lfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_lfreev - implicit none - !....parameters... - integer(psb_lpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_lfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - 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 (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_lfreev - subroutine psb_lfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_lfree_vect implicit none diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 index 2452446db..270271149 100644 --- a/base/tools/psb_lins.f90 +++ b/base/tools/psb_lins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_linsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_linsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_lpk_), intent(in) :: val(:) - integer(psb_lpk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_linsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_linsvi - - subroutine psb_lins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_lins_vect use psi_mod @@ -523,197 +390,6 @@ end subroutine psb_lins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_linsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - integer The source dense submatrix. -! x(:,:) - integer The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_linsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_linsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_lpk_), intent(in) :: val(:,:) - integer(psb_lpk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_linsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_linsi - - - subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_lins_multivect use psi_mod diff --git a/base/tools/psb_mallc_a.f90 b/base/tools/psb_mallc_a.f90 new file mode 100644 index 000000000..65388bf5f --- /dev/null +++ b/base/tools/psb_mallc_a.f90 @@ -0,0 +1,246 @@ +! +! 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. +! +! +! +! File: psb_mallc.f90 +! +! Function: psb_malloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_malloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_malloc + use psi_mod + implicit none + + !....parameters... + integer(psb_mpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: np,me,err,nr,i,j,err_act + integer(psb_ipk_) :: ictxt,n_ + integer(psb_ipk_) :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + err=0 + int_err(1)=0 + 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 + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='integer(psb_mpk_)') + goto 9999 + endif + + x(:,:) = mzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_malloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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. +!!$ +!!$ +! +! Function: psb_mallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_mallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_mallocv + use psi_mod + implicit none + + !....parameters... + integer(psb_mpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='integer(psb_mpk_)') + goto 9999 + endif + + x(:) = mzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_mallocv + diff --git a/base/tools/psb_masb_a.f90 b/base/tools/psb_masb_a.f90 new file mode 100644 index 000000000..5e78cbdfc --- /dev/null +++ b/base/tools/psb_masb_a.f90 @@ -0,0 +1,254 @@ +! +! 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. +! +! +! File: psb_masb.f90 +! +! Subroutine: psb_masb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_masb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_masb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_mgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_masb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_masb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_masbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_masbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + int_err(1) = 0 + name = 'psb_mgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_masbv diff --git a/base/tools/psb_mfree_a.f90 b/base/tools/psb_mfree_a.f90 new file mode 100644 index 000000000..95acd522b --- /dev/null +++ b/base/tools/psb_mfree_a.f90 @@ -0,0 +1,162 @@ +! +! 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. +! +! +! File: psb_mfree.f90 +! +! Subroutine: psb_mfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_mfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_mfree + implicit none + + !....parameters... + integer(psb_mpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_mfree' + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_mfree + + + +! Subroutine: psb_mfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_mfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_mfreev + implicit none + !....parameters... + integer(psb_mpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_mfreev' + + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + 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 (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_mfreev diff --git a/base/tools/psb_mins_a.f90 b/base/tools/psb_mins_a.f90 new file mode 100644 index 000000000..a1aa68e71 --- /dev/null +++ b/base/tools/psb_mins_a.f90 @@ -0,0 +1,371 @@ +! +! 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: psb_minsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - integer The source dense submatrix. +! x(:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_minsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_minsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:) + integer(psb_mpk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_minsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_minsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_minsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - integer The source dense submatrix. +! x(:,:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_minsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_minsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:,:) + integer(psb_mpk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_minsi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_minsi + diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 7777a4496..09ceedc0c 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_salloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_salloc - use psi_mod - implicit none - - !....parameters... - real(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - 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 - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') - goto 9999 - endif - - x(:,:) = szero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_salloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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. -!!$ -!!$ -! -! Function: psb_sallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_sallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_sallocv - use psi_mod - implicit none - - !....parameters... - real(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') - goto 9999 - endif - - x(:) = szero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sallocv - - subroutine psb_salloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_salloc_vect use psi_mod diff --git a/base/tools/psb_sallc_a.f90 b/base/tools/psb_sallc_a.f90 new file mode 100644 index 000000000..4711125ec --- /dev/null +++ b/base/tools/psb_sallc_a.f90 @@ -0,0 +1,246 @@ +! +! 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. +! +! +! +! File: psb_sallc.f90 +! +! Function: psb_salloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_salloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_salloc + use psi_mod + implicit none + + !....parameters... + real(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: np,me,err,nr,i,j,err_act + integer(psb_ipk_) :: ictxt,n_ + integer(psb_ipk_) :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + err=0 + int_err(1)=0 + 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 + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + x(:,:) = szero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_salloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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. +!!$ +!!$ +! +! Function: psb_sallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_sallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_sallocv + use psi_mod + implicit none + + !....parameters... + real(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + goto 9999 + endif + + x(:) = szero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sallocv + diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index 496303cf0..5d4754646 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - real, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_sasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_sasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_sgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_sasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - real, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_sasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_sasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_sgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sasbv - - subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_sasb_vect implicit none diff --git a/base/tools/psb_sasb_a.f90 b/base/tools/psb_sasb_a.f90 new file mode 100644 index 000000000..9e8c74c6e --- /dev/null +++ b/base/tools/psb_sasb_a.f90 @@ -0,0 +1,254 @@ +! +! 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. +! +! +! File: psb_sasb.f90 +! +! Subroutine: psb_sasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_sasb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_sasb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_sgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sasb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_sasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sasbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_sasbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + int_err(1) = 0 + name = 'psb_sgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sasbv diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index d0419aa41..34f03caec 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - real, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_sfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_sfree - implicit none - - !....parameters... - real(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_sfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sfree - - - -! Subroutine: psb_sfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - real, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_sfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_sfreev - implicit none - !....parameters... - real(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_sfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - 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 (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sfreev - subroutine psb_sfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_sfree_vect implicit none diff --git a/base/tools/psb_sfree_a.f90 b/base/tools/psb_sfree_a.f90 new file mode 100644 index 000000000..ccabd82e7 --- /dev/null +++ b/base/tools/psb_sfree_a.f90 @@ -0,0 +1,162 @@ +! +! 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. +! +! +! File: psb_sfree.f90 +! +! Subroutine: psb_sfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_sfree + implicit none + + !....parameters... + real(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_sfree' + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sfree + + + +! Subroutine: psb_sfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_sfreev + implicit none + !....parameters... + real(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_sfreev' + + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + 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 (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sfreev diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index f6342a041..ab12c61fb 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_sinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:) - real(psb_spk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_sinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sinsvi - - subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_sins_vect use psi_mod @@ -523,197 +390,6 @@ end subroutine psb_sins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_sinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - real The source dense submatrix. -! x(:,:) - real The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_sinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:,:) - real(psb_spk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_sinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sinsi - - - subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_sins_multivect use psi_mod diff --git a/base/tools/psb_sins_a.f90 b/base/tools/psb_sins_a.f90 new file mode 100644 index 000000000..e9726d6b7 --- /dev/null +++ b/base/tools/psb_sins_a.f90 @@ -0,0 +1,371 @@ +! +! 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: psb_sinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - real The source dense submatrix. +! x(:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_sinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_sinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_sinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - real The source dense submatrix. +! x(:,:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_sinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + real(psb_spk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_sinsi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sinsi + diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index dcc2b677b..018c5ce41 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_zalloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_zalloc - use psi_mod - implicit none - - !....parameters... - complex(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - 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 - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') - goto 9999 - endif - - x(:,:) = zzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zalloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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. -!!$ -!!$ -! -! Function: psb_zallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_zallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_zallocv - use psi_mod - implicit none - - !....parameters... - complex(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') - goto 9999 - endif - - x(:) = zzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zallocv - - subroutine psb_zalloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_zalloc_vect use psi_mod diff --git a/base/tools/psb_zallc_a.f90 b/base/tools/psb_zallc_a.f90 new file mode 100644 index 000000000..edd61c709 --- /dev/null +++ b/base/tools/psb_zallc_a.f90 @@ -0,0 +1,246 @@ +! +! 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. +! +! +! +! File: psb_zallc.f90 +! +! Function: psb_zalloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_zalloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_zalloc + use psi_mod + implicit none + + !....parameters... + complex(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: np,me,err,nr,i,j,err_act + integer(psb_ipk_) :: ictxt,n_ + integer(psb_ipk_) :: int_err(5),exch(3) + character(len=20) :: name + + name='psb_geall' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + err=0 + int_err(1)=0 + 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 + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + int_err(1)=1 + call psb_errpush(info,name,int_err) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr*n_ + call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') + goto 9999 + endif + + x(:,:) = zzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zalloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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. +!!$ +!!$ +! +! Function: psb_zallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_zallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_zallocv + use psi_mod + implicit none + + !....parameters... + complex(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + int_err(1)=nr + call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') + goto 9999 + endif + + x(:) = zzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zallocv + diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 5e027b78a..df8bfb62b 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - complex, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_zasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_zasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_zgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_zasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - complex, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_zasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_zasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_zgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zasbv - - subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_zasb_vect implicit none diff --git a/base/tools/psb_zasb_a.f90 b/base/tools/psb_zasb_a.f90 new file mode 100644 index 000000000..4cd53968c --- /dev/null +++ b/base/tools/psb_zasb_a.f90 @@ -0,0 +1,254 @@ +! +! 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. +! +! +! File: psb_zasb.f90 +! +! Subroutine: psb_zasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_zasb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_zasb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + name='psb_zgeasb_m' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zasb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_zasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_zasbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_zasbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + int_err(1) = 0 + name = 'psb_zgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zasbv diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index ad2a02070..cdb9d0470 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - complex, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_zfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_zfree - implicit none - - !....parameters... - complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_zfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zfree - - - -! Subroutine: psb_zfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - complex, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_zfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_zfreev - implicit none - !....parameters... - complex(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_zfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - 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 (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zfreev - subroutine psb_zfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_zfree_vect implicit none diff --git a/base/tools/psb_zfree_a.f90 b/base/tools/psb_zfree_a.f90 new file mode 100644 index 000000000..9c28fada4 --- /dev/null +++ b/base/tools/psb_zfree_a.f90 @@ -0,0 +1,162 @@ +! +! 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. +! +! +! File: psb_zfree.f90 +! +! Subroutine: psb_zfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_zfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_zfree + implicit none + + !....parameters... + complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_zfree' + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zfree + + + +! Subroutine: psb_zfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_zfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_zfreev + implicit none + !....parameters... + complex(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name='psb_zfreev' + + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + 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 (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zfreev diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index c03819fe0..8044319b4 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_zinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:) - complex(psb_dpk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_zinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zinsvi - - subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_zins_vect use psi_mod @@ -523,197 +390,6 @@ end subroutine psb_zins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ 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: psb_zinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - complex The source dense submatrix. -! x(:,:) - complex The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_zinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:,:) - complex(psb_dpk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_zinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - 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 - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zinsi - - - subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_zins_multivect use psi_mod diff --git a/base/tools/psb_zins_a.f90 b/base/tools/psb_zins_a.f90 new file mode 100644 index 000000000..8cd93f8c8 --- /dev/null +++ b/base/tools/psb_zins_a.f90 @@ -0,0 +1,371 @@ +! +! 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: psb_zinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - complex The source dense submatrix. +! x(:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_zinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_zinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ 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: psb_zinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - complex The source dense submatrix. +! x(:,:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_zinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:,:) + complex(psb_dpk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_zinsi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + 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 + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zinsi +