Merge branch 'communication_v2' into test_dev

Mirror test_dev tree to communication_v2, preserving the unit-test CI workflow (.github/workflows/cmake-build.yml).
test_dev
Stack-1 2 weeks ago
commit a0df004218

@ -1,6 +1,6 @@
$Format:%d%n%n$
# Fall back version, probably last release:
3.9.0
3.9.1
# PSBLAS version file.
#

36
.gitattributes vendored

@ -0,0 +1,36 @@
*.a export-ignore
*.o export-ignore
*.mod export-ignore
*.smod export-ignore
*~ export-ignore
.git* export-ignore
rsb export-ignore
rsb/ export-ignore
rsb/** export-ignore
Make.inc export-ignore
config export-ignore
config/ export-ignore
config/** export-ignore
configure.ac export-ignore
config.log export-ignore
config.status export-ignore
aclocal.m4 export-ignore
autogen.sh export-ignore
autom4te.cache export-ignore
Dockerfile export-ignore
.travis.yml export-ignore
# generated folder
./include/** export-ignore
./modules/** export-ignore
docs/src export-ignore
docs/doxypsb export-ignore
docs/Makefile export-ignore
# the executable from tests
test/computational_routines export-ignore
test/computational_routines export-ignore
test/omp export-ignore
test/openacc export-ignore
test/torture export-ignore

10
.gitignore vendored

@ -4,7 +4,11 @@
*.mtx
*.smod
*~
*.log
*.out
*.err
*.csv
leonardo_comm_script.sh
# header files generated
/cbind/*.h
@ -22,9 +26,7 @@ config.status
docs/src/tmp
autom4te.cache
build/
# the executable from tests
runs
data

@ -4,7 +4,8 @@
#-----------------------------------
# Set oldest allowable CMake version
#-----------------------------------
cmake_minimum_required(VERSION 3.20)
cmake_minimum_required(VERSION 3.11...4.2)
cmake_policy(VERSION 3.11.1...3.13.3)
set(CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake")
@ -59,7 +60,8 @@ include(CheckOutOfSourceBuild)
# Define coverage flags and report untested compilers
#----------------------------------------------------
if ("${CMAKE_Fortran_COMPILER_ID}" MATCHES "GNU" )
set(CMAKE_Fortran_COMPILER mpifort CACHE STRING "MPI Fortran compiler" FORCE)
set(gfortran_compiler true)
set(CMAKE_Fortran_COMPILER mpifort)
set ( CMAKE_C_FLAGS_CODECOVERAGE "-fprofile-arcs -ftest-coverage -O0"
CACHE STRING "Code coverage C compiler flags")
@ -130,6 +132,11 @@ include("${CMAKE_CURRENT_LIST_DIR}/cmake/CapitalizeString.cmake")
message(STATUS "Using compiler ${CMAKE_C_COMPILER};")
# Find PSBLAS constants
include(${CMAKE_CURRENT_LIST_DIR}/cmake/readPSBConst.cmake)
_psb_read_const()
_psb_read_desc_const()
# Set default values for IPK_SIZE and LPK_SIZE
set(DEFAULT_IPK_SIZE 4)
set(DEFAULT_LPK_SIZE 8)
@ -303,95 +310,72 @@ if(HAVE_SAME_TYPE_AS)
message(STATUS "-DPSB_HAVE_SAME_TYPE_AS")
endif()
# ============================================================
# Robust MPI configuration (C + Fortran) for PSBLAS
# Works with modern CMake, MPICH/OpenMPI, local servers, and CI
# ============================================================
find_package(MPI REQUIRED COMPONENTS C Fortran)
#----------------------------------------------------------------------------
# MPI detection and configuration
#----------------------------------------------------------------------------
find_package(MPI REQUIRED Fortran)
if(MPI_FOUND)
message(STATUS ">>> MPI found successfully!")
message(STATUS "MPI version: ${MPI_VERSION}")
# ------------------------------------------------------------
# Extract include paths and library info from imported targets
# ------------------------------------------------------------
if(TARGET MPI::MPI_Fortran)
get_target_property(_mpi_fortran_inc MPI::MPI_Fortran INTERFACE_INCLUDE_DIRECTORIES)
get_target_property(_mpi_fortran_lib MPI::MPI_Fortran IMPORTED_LOCATION)
get_target_property(_mpi_fortran_link MPI::MPI_Fortran INTERFACE_LINK_LIBRARIES)
if(_mpi_fortran_inc)
include_directories(BEFORE ${_mpi_fortran_inc})
message(STATUS "MPI Fortran include paths: ${_mpi_fortran_inc}")
endif()
endif()
if(TARGET MPI::MPI_C)
get_target_property(_mpi_c_inc MPI::MPI_C INTERFACE_INCLUDE_DIRECTORIES)
get_target_property(_mpi_c_lib MPI::MPI_C IMPORTED_LOCATION)
message(STATUS ">>> MPI found: ${MPI_C_LIBRARIES} ${MPI_Fortran_LIBRARIES}")
if(_mpi_c_inc)
include_directories(BEFORE ${_mpi_c_inc})
message(STATUS "MPI C include paths: ${_mpi_c_inc}")
endif()
endif()
# ------------------------------------------------------------
#-----------------------------------------------
# Fedora-specific workaround for noexecstack flag
# ------------------------------------------------------------
#-----------------------------------------------
if((MPI_C_LINK_FLAGS MATCHES "noexecstack") OR (MPI_Fortran_LINK_FLAGS MATCHES "noexecstack"))
message(WARNING
"The `noexecstack` linker flag was found in MPI_<lang>_LINK_FLAGS.\n"
"This can cause segmentation faults in Fortran codes.\n"
"Replacing `noexecstack` with `execstack`."
"The `noexecstack` linker flag was found in the MPI_<lang>_LINK_FLAGS variable.
This can cause segmentation faults in Fortran codes.
Replacing `noexecstack` with `execstack`."
)
string(REPLACE "noexecstack" "execstack" MPI_C_LINK_FLAGS "${MPI_C_LINK_FLAGS}")
string(REPLACE "noexecstack" "execstack" MPI_Fortran_LINK_FLAGS "${MPI_Fortran_LINK_FLAGS}")
string(REPLACE "noexecstack" "execstack" MPI_C_LINK_FLAGS_FIXED ${MPI_C_LINK_FLAGS})
string(REPLACE "noexecstack" "execstack" MPI_Fortran_LINK_FLAGS_FIXED ${MPI_Fortran_LINK_FLAGS})
set(MPI_C_LINK_FLAGS "${MPI_C_LINK_FLAGS_FIXED}" CACHE STRING "MPI C linking flags" FORCE)
set(MPI_Fortran_LINK_FLAGS "${MPI_Fortran_LINK_FLAGS_FIXED}" CACHE STRING "MPI Fortran linking flags" FORCE)
endif()
# ------------------------------------------------------------
# Compiler and linker flags
# ------------------------------------------------------------
#-----------------------------------------------
# Compiler and linker flags setup
#-----------------------------------------------
list(REMOVE_DUPLICATES MPI_Fortran_INCLUDE_PATH)
include_directories(BEFORE ${MPI_C_INCLUDE_PATH} ${MPI_Fortran_INCLUDE_PATH})
set(CMAKE_C_COMPILE_FLAGS "${CMAKE_C_COMPILE_FLAGS} ${MPI_C_COMPILE_FLAGS}")
set(CMAKE_C_LINK_FLAGS "${CMAKE_C_LINK_FLAGS} ${MPI_C_LINK_FLAGS}")
set(CMAKE_C_LINK_FLAGS "${CMAKE_C_LINK_FLAGS} ${MPI_C_LINK_FLAGS}")
set(CMAKE_Fortran_COMPILE_FLAGS "${CMAKE_Fortran_COMPILE_FLAGS} ${MPI_Fortran_COMPILE_FLAGS}")
set(CMAKE_Fortran_LINK_FLAGS "${CMAKE_Fortran_LINK_FLAGS} ${MPI_Fortran_LINK_FLAGS}")
set(CMAKE_Fortran_LINK_FLAGS "${CMAKE_Fortran_LINK_FLAGS} ${MPI_Fortran_LINK_FLAGS}")
message(STATUS "MPI include paths: ${MPI_Fortran_INCLUDE_PATH}")
message(STATUS "Fortran link flags: ${CMAKE_Fortran_LINK_FLAGS}")
# ------------------------------------------------------------
# Ensure mpi.mod is available for Fortran (legacy fallback)
# ------------------------------------------------------------
#-----------------------------------------------
# Ensure mpi.mod is available for CMake
#-----------------------------------------------
set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/modules)
file(MAKE_DIRECTORY ${CMAKE_Fortran_MODULE_DIRECTORY})
# Try to copy mpi.mod or MPI.mod into module directory
set(_mpi_mod_found FALSE)
if(_mpi_fortran_inc)
foreach(_mod_name mpi.mod MPI.mod)
foreach(_inc ${_mpi_fortran_inc})
if(EXISTS "${_inc}/${_mod_name}")
file(COPY "${_inc}/${_mod_name}" DESTINATION "${CMAKE_Fortran_MODULE_DIRECTORY}")
message(STATUS "Copied ${_mod_name} from ${_inc}")
set(_mpi_mod_found TRUE)
break()
endif()
endforeach()
if(_mpi_mod_found)
foreach(_mpi_mod_name mpi.mod MPI.mod)
foreach(_mpi_inc ${MPI_Fortran_INCLUDE_PATH})
if(EXISTS "${_mpi_inc}/${_mpi_mod_name}")
file(COPY "${_mpi_inc}/${_mpi_mod_name}" DESTINATION "${CMAKE_Fortran_MODULE_DIRECTORY}")
message(STATUS "Copied ${_mpi_mod_name} from ${_mpi_inc}")
set(_mpi_mod_found TRUE)
break()
endif()
endforeach()
endif()
if(_mpi_mod_found)
break()
endif()
endforeach()
if(NOT _mpi_mod_found)
message(FATAL "mpi.mod not found in MPI include paths; assuming mpifort provides it internally. Skipping copy.")
message(WARNING "mpi.mod not found in MPI include paths; assuming it is built-in to mpifort.")
endif()
# ------------------------------------------------------------
#-----------------------------------------------
# Enable MPI Fortran module support
# ------------------------------------------------------------
#-----------------------------------------------
if(MPI_Fortran_HAVE_F90_MODULE OR MPI_Fortran_HAVE_F08_MODULE)
add_compile_options(-DPSB_MPI_MOD)
message(STATUS "Defined: -DPSB_MPI_MOD")
@ -400,9 +384,9 @@ if(MPI_FOUND)
set(PSB_SERIAL_MPI OFF)
else()
# ------------------------------------------------------------
# Fallback to serial mode
# ------------------------------------------------------------
#-----------------------------------------------
# Fallback to serial mode (no MPI found)
#-----------------------------------------------
message(WARNING ">>> MPI not found — building in serial mode")
add_compile_options(-DPSB_SERIAL_MPI -DPSB_MPI_MOD)
set(PSB_SERIAL_MPI ON)
@ -441,6 +425,7 @@ find_package(METIS)
if(METIS_FOUND)
include(CheckTypeSize)
message(STATUS "METIS PATH ${METIS_INCLUDES} and metis libraries ${METIS_LIBRARIES}")
# Make sure this path is correct
# set(METISINCFILE "metis.h") # Adjust this to your actual path
@ -458,6 +443,9 @@ if(METIS_FOUND)
# Check for real sizes using try_compile
include(CheckCSourceCompiles)
#[=====[
# Function to check the size of a type
function(check_metis_real_type type_name)
set(source_code "
@ -469,25 +457,42 @@ if(METIS_FOUND)
}")
# Create a temporary source file
file(WRITE "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp/test_size.c" "${source_code}")
#file(WRITE "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp/test_size.c" "${source_code}")
# Try to compile it
try_compile(COMPILER_RESULT "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp"
"${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp/test_size.c")
#try_compile(COMPILER_RESULT "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp"
# "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp/test_size.c")
# Check the result and read the output
if (COMPILER_RESULT)
set(test_file "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp/test_metis_size.c")
file(WRITE "${test_file}" "${source_code}")
# Use try_run to compile AND execute
try_run(RUN_RESULT COMPILE_RESULT
"${CMAKE_BINARY_DIR}"
"${test_file}"
CMAKE_FLAGS "-DINCLUDE_DIRECTORIES=${METIS_INCLUDES}"
RUN_OUTPUT_VARIABLE type_size
COMPILE_OUTPUT_VARIABLE compile_log
)
if(COMPILE_RESULT AND (RUN_RESULT EQUAL 0))
# if (COMPILER_RESULT)
execute_process(COMMAND "${CMAKE_BINARY_DIR}/CMakeFiles/CMakeTmp/test_size"
OUTPUT_VARIABLE type_size)
string(STRIP "${type_size}" type_size)
message(STATUS "Metis ?: ${type_size};")
if (type_name STREQUAL "float")
set(PSB_METIS_REAL_32 "${type_size}" PARENT_SCOPE)
message(STATUS "Metis 32: ${type_size}")
# add_definitions(-DPSB_METIS_REAL_32)
set(CREALMETIS "#define PSB_METIS_REAL_32" PARENT_SCOPE)
elseif (type_name STREQUAL "double")
set(PSB_METIS_REAL_64 "${type_size}" PARENT_SCOPE)
#add_definitions(-DPSB_METIS_REAL_64)
set(CREALMETIS "#define PSB_METIS_REAL_64" PARENT_SCOPE)
set(CREALMETIS "#define PSB_METIS_REAL_64" PARENT_SCOPE)
message(STATUS "Metis 64: ${type_size}")
endif()
else()
message(WARNING "Failed to compile test for type size: ${type_name}")
@ -497,44 +502,65 @@ if(METIS_FOUND)
# Check for both float and double
check_metis_real_type(float)
check_metis_real_type(double)
#]=====]
# Set HAVE_METIS if METIS is found
#add_compile_options(-DPSB_HAVE_METIS)
# set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DPSB_HAVE_METIS")
# Determine METIS_INDEX based on real type sizes
if(DEFINED PSB_METIS_REAL_32)
set(METIS_INDEX 32)
elseif(DEFINED PSB_METIS_REAL_64)
set(METIS_INDEX 64)
else()
message(WARNING "Neither METIS_REAL_32 nor METIS_REAL_64 is defined.")
set(METIS_INDEX 64) # Default to 64 if not defined
endif()
# Check conditions for LPK_SIZE and METIS_INDEX
if(LPK_SIZE STREQUAL "4")
if(METIS_INDEX STREQUAL "64")
# Mismatch between METIS size and PSBLAS LPK
message(FATAL " Mismatch between metis ${METIS_INDEX} size and psblas LPK size ${LPK_SIZE}")
set(METIS_FOUND FALSE)
# 1. Tell CMake where to find metis.h for the check
set(CMAKE_EXTRA_INCLUDE_FILES "${METIS_INCLUDES}/metis.h")
# 2. Check the size of Metis's own type: real_t
# This replaces checking 'float' and 'double' separately
check_type_size("real_t" METIS_REAL_SIZE)
check_type_size("idx_t" METIS_IDX_SIZE)
# 3. Handle the result
if(METIS_IDX_SIZE)
if(METIS_IDX_SIZE EQUAL 4)
set(CINTMETIS "#define PSB_METIS_32")
message(STATUS "Metis detected as 32-bit (idx_t is 4 bytes)")
set(METIS_INDEX 32)
elseif(METIS_IDX_SIZE EQUAL 8)
set(CINTMETIS "#define PSB_METIS_64")
message(STATUS "Metis detected as 64-bit (idx_t is 8 bytes)")
set(METIS_INDEX 64)
endif()
endif()
if(LPK_SIZE STREQUAL "8")
if(METIS_INDEX STREQUAL "32")
# Mismatch between METIS size and PSBLAS LPK
message(FATAL " Mismatch between metis ${METIS_INDEX} size and psblas LPK size ${LPK_SIZE}")
set(METIS_FOUND FALSE)
else()
message(WARNING "Could not determine size of idx_t from metis.h. Check METIS_INCLUDES.")
endif()
# 3. Handle the result
if(METIS_REAL_SIZE)
if(METIS_REAL_SIZE EQUAL 4)
set(CREALMETIS "#define PSB_METIS_REAL_32")
message(STATUS "Metis detected as 32-bit (real_t is 4 bytes)")
elseif(METIS_REAL_SIZE EQUAL 8)
set(CREALMETIS "#define PSB_METIS_REAL_64")
message(STATUS "Metis detected as 64-bit (real_t is 8 bytes)")
endif()
endif()
else()
message(WARNING "Could not determine size of real_t from metis.h. Check METIS_INCLUDES.")
endif()
# clean the variable
set(CMAKE_EXTRA_INCLUDE_FILES "")
# Mismatch Logic Below
if(LPK_SIZE STREQUAL "4" AND METIS_INDEX EQUAL 64)
message(WARNING "Mismatch: Metis IDX is 64-bit but PSBLAS LPK is 32-bit")
set(METIS_FOUND FALSE)
set(CREALMETIS "")
set(CINTMETIS "")
elseif(LPK_SIZE STREQUAL "8" AND METIS_INDEX EQUAL 32)
set(METIS_FOUND FALSE)
message(WARNING "Mismatch: Metis IDX is 32-bit but PSBLAS LPK is 64-bit")
set(CREALMETIS "")
set(CINTMETIS "")
endif()
if(METIS_FOUND)
if(METIS_FOUND)
# Make sure this path is correct
set(METISINCFILE "metis.h") # Adjust this to your actual path
@ -553,7 +579,7 @@ if(METIS_FOUND)
set(CHAVEMETIS "#define PSB_HAVE_METIS")
set(CINTMETIS "#define PSB_METIS_${METIS_INDEX}")
# set(CINTMETIS "#define PSB_METIS_${METIS_INDEX}")
# set(CREALMETIS "#define PSB_METIS_REAL_${LPK_SIZE}")
# Configure the header file
configure_file(${HEADER_TEMPLATE} ${HEADER_OUTPUT} @ONLY)
@ -658,7 +684,7 @@ install(EXPORT ${CMAKE_PROJECT_NAME}-targets
include(CMakePackageConfigHelpers) # standard CMake module
write_basic_package_version_file(
"${CMAKE_CURRENT_BINARY_DIR}/${CMAKE_PROJECT_NAME}ConfigVersion.cmake"
VERSION "${psblas_VERSION}"
VERSION "${VERSION}"
COMPATIBILITY SameMajorVersion
)
@ -825,7 +851,7 @@ set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/modules)
message(STATUS "fortran module direcotry ${CMAKE_BINARY_DIR}/${CMAKE_INSTALL_INCLUDEDIR}")
message(STATUS "fortran module directory ${CMAKE_BINARY_DIR}/${CMAKE_INSTALL_INCLUDEDIR}")
include_directories(${MPI_Fortran_INCLUDE_PATH})
@ -841,6 +867,7 @@ set_target_properties(base
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_base
LINKER_LANGUAGE Fortran
VERSION ${VERSION} SOVERSION ${SOVERSION}
)
target_include_directories(base PUBLIC
@ -873,6 +900,7 @@ set_target_properties(prec
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_prec
LINKER_LANGUAGE Fortran
VERSION ${VERSION} SOVERSION ${SOVERSION}
)
target_include_directories(prec PUBLIC
$<BUILD_INTERFACE:${CMAKE_BINARY_DIR}/modules>
@ -888,6 +916,7 @@ set_target_properties(linsolve
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_linsolve
LINKER_LANGUAGE Fortran
VERSION ${VERSION} SOVERSION ${SOVERSION}
)
target_include_directories(linsolve PUBLIC
$<BUILD_INTERFACE:${CMAKE_BINARY_DIR}/modules>
@ -904,6 +933,7 @@ set_target_properties(ext
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_ext
LINKER_LANGUAGE Fortran
VERSION ${VERSION} SOVERSION ${SOVERSION}
)
target_include_directories(ext PUBLIC
$<BUILD_INTERFACE:${CMAKE_BINARY_DIR}/modules>
@ -923,7 +953,8 @@ if(WIN32)
set_target_properties(psb_util_C
PROPERTIES
LINKER_LANGUAGE C
POSITION_INDEPENDENT_CODE TRUE)
POSITION_INDEPENDENT_CODE TRUE
VERSION ${VERSION} SOVERSION ${SOVERSION})
target_link_libraries(psb_util_C
PUBLIC kernel32 user32 shell32)
endif()
@ -949,6 +980,7 @@ set_target_properties(util
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_util
LINKER_LANGUAGE Fortran
VERSION ${VERSION} SOVERSION ${SOVERSION}
)
target_include_directories(util PUBLIC
$<BUILD_INTERFACE:${CMAKE_BINARY_DIR}/modules>
@ -1009,6 +1041,7 @@ set_target_properties(cbind
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_cbind
LINKER_LANGUAGE Fortran
VERSION ${VERSION} SOVERSION ${SOVERSION}
)
#target_include_directories(cbind PUBLIC
# $<BUILD_INTERFACE:${CMAKE_BINARY_DIR}/modules>
@ -1155,6 +1188,7 @@ if(PSB_BUILD_CUDA)
PROPERTIES
POSITION_INDEPENDENT_CODE TRUE
OUTPUT_NAME psb_cuda
VERSION ${VERSION} SOVERSION ${SOVERSION}
LINKER_LANGUAGE C)
# Include directories for the CUDA library

@ -1,7 +1,5 @@
Parallel Sparse BLAS version 3.9
(C) Copyright 2006-2025
Salvatore Filippone
Alfredo Buttari
(C) Copyright 2025 Salvatore Filippone
(C) Copyright 2025 Alfredo Buttari
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
@ -13,7 +11,7 @@
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.
software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -70,16 +70,16 @@ UTILMODNAME=@UTILMODNAME@
CBINDLIBNAME=libpsb_cbind.a
OACCD=@OACCD@
OACCMODS=@OACCMODS@
OACCLD=@OACCLD@
FCOPENACC=@FCOPENACC@
CCOPENACC=@CCOPENACC@
CXXOPENACC=@CXXOPENACC@
CUDAD=@CUDAD@
CUDAMODS=@CUDAMODS@
CUDALD=@CUDALD@
LCUDA=@LCUDA@
SPGPU_LIBS=@SPGPU_LIBS@
LPSB_CUDA=@LPSB_CUDA@
CUDA_DIR=@CUDA_DIR@
CUDA_INCLUDES=@CUDA_INCLUDES@
@ -102,4 +102,4 @@ CUDEFINES=@CUDEFINES@
@PSBLASRULES@
PSBGPULDLIBS=$(LCUDA) $(SPGPU_LIBS) $(CUDA_LIBS) $(PSBLDLIBS) $(LIBS)
PSBGPULDLIBS=$(LPSB_CUDA) $(CUDA_LIBS) $(PSBLDLIBS) $(LIBS)

@ -1,6 +1,6 @@
include Make.inc
all: dirs based precd linslvd utild cbindd extd $(CUDAD) $(OACCD) libd
all: dirs mods objs libd
@echo "====================================="
@echo "PSBLAS libraries Compilation Successful."
@ -9,13 +9,35 @@ dirs:
(if test ! -d include ; then mkdir include; fi; $(INSTALL_DATA) Make.inc include/Make.inc.psblas)
(if test ! -d modules ; then mkdir modules; fi;)
precd: based
utild: based
linslvd: precd
extd: based
cudad: extd
oaccd: extd
cbindd: based precd linslvd utild
mods: basemods utilmods precmods linslvmods cbindmods extmods $(CUDAMODS) $(OACCMODS)
basemods:
$(MAKE) -C base mods
precmods: basemods
$(MAKE) -C prec mods
linslvmods: precmods
$(MAKE) -C linsolve mods
utilmods: basemods
$(MAKE) -C util mods
cbindmods: basemods precmods linslvmods utilmods extmods $(CUDAMODS)
$(MAKE) -C cbind objs
extmods: basemods
$(MAKE) -C ext mods
cudamods: extmods
$(MAKE) -C cuda mods
oaccmods: extmods
$(MAKE) -C openacc mods
objs: mods based precd linslvd utild cbindd extd $(CUDAD) $(OACCD)
based: basemods
precd: precmods
utild: utilmods
linslvd: linslvmods
extd: extmods
cudad: cudamods
oaccd: oaccmods
cbindd: cbindmods
libd: based precd linslvd utild cbindd extd $(CUDALD) $(OACCLD)
$(MAKE) -C base lib
@ -42,9 +64,9 @@ cbindd:
$(MAKE) -C cbind objs
extd:
$(MAKE) -C ext objs
cudad:
cudad: cudamods
$(MAKE) -C cuda objs
oaccd:
oaccd: oaccmods
$(MAKE) -C openacc objs

@ -51,14 +51,13 @@ The main reference for the serial sparse BLAS is:
## Installing
To compile and run our software you will need the following
prerequisites (see also SERIAL below):
To compile (using configure/make/make install) and run our software
you will need the following
prerequisites (see also SERIAL below):
1. A working version of MPI
1. A working version of MPI.
2. A version of the BLAS; if you don't have a specific version for your
platform you may try ATLAS available from
http://math-atlas.sourceforge.net/
2. A version of the BLAS; you can specify a specific version with `--with-blas`
3. We have had good results with the METIS library, from
https://github.com/KarypisLab/METIS.
@ -70,12 +69,20 @@ prerequisites (see also SERIAL below):
We use the C interface to AMD.
6. If you have CUDA available, use
--enable-cuda to compile CUDA-enabled methods
--with-cudadir=<path> to specify the CUDA toolkit location
--with-cudacc=XX,YY,ZZ to specify a list of target CCs (compute
capabilities) to compile the CUDA code for.
The configure script will generate a Make.inc file suitable for building
- `--enable-cuda` to compile CUDA-enabled methods
- `--with-cudadir=<path>` to specify the CUDA toolkit location
- `--with-cudacc=XX,YY,ZZ` to specify a list of target CCs (compute
capabilities).
CUDA versions have specific compatibility requirements;
for example:
- CUDA version 11.8 supports GNU compilers up to version 11
- CUDA versions 12.3 through 12.6 support GNU compilers up to version 13
- CUDA versions 12.8 and 12.9 support GNU compilers up to version 14
- CUDA version 13.0 supports GNU compilers up to version 15
For further information please refer to the CUDA documentation at
https://developer.nvidia.com/cuda/gpus
The configure script will generate a `Make.inc` file suitable for building
the library. The script is capable of recognizing the needed libraries
with their default names; if they are in unusual places consider adding
the paths with `--with-libs`, or explicitly specifying the names in
@ -94,7 +101,7 @@ the paths with `--with-libs`, or explicitly specifying the names in
> (see [http://modules.sourceforge.net/](http://modules.sourceforge.net/)), and load the relevant
> variables with (e.g.)
> ```
> module load gcc/13.2.0 openmpi/4.1.6
> module load gcc/14.2.0 openmpi/5.0.8
> ```
> This will delegate to the modules setup to make sure that the version of
> openmpi in use is the one compiled with the gnu46 compilers. After the
@ -106,11 +113,20 @@ After you have Make.inc fixed, run
make
```
to compile the library; go to the test directory and its subdirectories
to get test programs done. If you specify `--prefix=/path` you can do make
install and the libraries will be installed under `/path/lib`, while the
module files will be installed under `/path/modules`. The regular and
experimental C interface header files are under `/path/include`.
to get test programs done.
You can then install with
```
make install
```
We recommend specifying `--prefix=/path` in the configure step, so that
the libraries will be installed under `/path/lib`,
the module files will be installed under `/path/modules`, the documentation under `/path/docs` and so on.
The C interface header files are under `/path/include`.
If `/path` is a system directory, you may need
```
sudo make install
```
If you do not specifye `--with-prefix` the usual default of `/usr` applies.
### Packaging changes, CUDA and GPU support
This version of PSBLAS incorporates into a single package three
@ -121,12 +137,12 @@ entities that were previously separated:
| PSBLAS-EXT | a library providing additional storage formats for matrices and vectors |
| SPGPU | a package of kernels for NVIDIA GPUs originally written by Davide Barbieri and Salvatore Filippone; see the license file [cuda/License-spgpu.md](cuda/License-spgpu.md) |
Moreover, the module and library previously called psb_krylovv are now called
Moreover, the module and library previously called psb_krylov are now called
psb_linsolve, but their usage is otherwise unchanged.
### OpenACC
There is a highly experimental version of an OpenACC interface,
you can access it by speficifying
you can compile it by speficifying
```bash
--enable-openacc --with-extraopenacc="-foffload=nvptx-none=-march=sm_70"
```
@ -144,7 +160,7 @@ cover what we use internally, it's not a complete replacement).
### Integers
We have two kind of integers: IPK for local indices, and LPK for
global indices. They can be specified independently at configure time,
global indices. Their size can be specified at configure time,
e.g.
```bash
--with-ipk=4 --with-lpk=8
@ -153,18 +169,75 @@ which is asking for 4-bytes local indices, and 8-bytes global indices
(this is the default).
## CMAKE
There is initial support for building with CMAKE. As of this time, it does not compile the CUDA part.
PSBLAS supports building with CMake (version 3.11 or higher). This method handles the automatic detection of compilers, MPI, and linear algebra libraries.
Standard Compilation (Without CUDA)
To perform a standard compilation, run:
### 1. Create and enter a dedicated build directory
```
mkdir build
cd build
```
### 2. Configure the project
```
cmake ..
```
### 3. Compile the libraries
```
make
```
If you wish to install PSBLAS in a specific location (similar to using the --prefix option in the legacy configure script), you must define the CMAKE_INSTALL_PREFIX variable.
To set a custom installation path, run the configuration command as follows:
#### Example: Installing PSBLAS to a specific folder in your home directory
```
cmake -DCMAKE_INSTALL_PREFIX=/home/user/psblas_install
```
### Compiling with CUDA Support
To enable GPU support via CUDA, you must set the PSB_BUILD_CUDA option to ON during the configuration step.
Important Compatibility Note: CUDA support is strictly incompatible with 8-byte local integers. If you manually set CMAKE_PSB_IPK to 8, CUDA support will be automatically disabled by the system.
To build with CUDA enabled:
## LLVM
The library has been successfully compiled and tested with LLVM version 20.1.0-rc2.
```
cmake -DPSB_BUILD_CUDA=ON ..
```
The compilation then proceed as before through make
When this flag is active, CMake will search for the CUDAToolkit, enable the CUDA language, and define necessary macros such as PSB_HAVE_CUDA.
### Customizing Integer Sizes
You can override the default integer sizes (4-byte local IPK and 8-byte global LPK) using the following variables:
Example: Using 8-byte global integers (default) and 4-byte local integers
```
cmake -DCMAKE_PSB_IPK=4 -DCMAKE_PSB_LPK=8 ..
```
### 4. Installation
To install the libraries, header files, and Fortran modules to your system (or a custom path defined by -DCMAKE_INSTALL_PREFIX), run:
```
make install
```
The files will be organized into the lib, include, and modules subdirectories within the installation prefix, same as the configure build.
## MPI and Compilers
The library has been successfully compiled and tested with multiple compilers
and MPI implementations; this release has been successfully tested with:
- MPICH 4.2.3, 4.3.0, 4.3.2
- OpenMPI 4.1.8. 5.0.7, 5.0.8, 5.0.9
combined with
- GNU compilers 10.5.0, 11.5.0, 12.5.0, 13.3.0, 14.2.0 14.3.0, 15.2.0
- LLVM 20.1.0 and 21.1.0 (except OpenMPI 4.1.8 which does not build with LLVM)
Moreover, it has been tested with the Intel OneAPI toolchain versions 2025.2 and 2025.3
As of this release, the NVIDIA compiler 25.7 fails to handle our code.
Cray, IBM and NAg compilers have been used for testing in the past, but not on this version.
## Documentation
Further information on installation and configuration can be found in the documentation.
See [docs/psblas-3.9.pdf](docs/psblas-3.9.pdf); an HTML version of the same document is
available in docs/html. Please consult the sample programs, especially
- [test/pargen/psb_s_pde2d.F90](test/pargen/psb_s_pde2d.F90) [test/pargen/psb_d_pde2d.F90](test/pargen/psb_d_pde2d.F90)
- [test/pargen/psb_s_pde2d.F90](test/pargen/psb_s_pde3d.F90) [test/pargen/psb_d_pde2d.F90](test/pargen/psb_d_pde3d.F90)
- [test/pdegen/psb_s_pde2d.F90](test/pdegen/psb_s_pde2d.F90) [test/pdegen/psb_d_pde2d.F90](test/pdegen/psb_d_pde2d.F90)
- [test/pdegen/psb_s_pde2d.F90](test/pdegen/psb_s_pde3d.F90) [test/pdegen/psb_d_pde2d.F90](test/pdegens/psb_d_pde3d.F90)
which contain examples for the solution of linear systems obtained by the discretization of a generic second-order differential equation in two:
```math
@ -208,18 +281,19 @@ Salvatore Filippone
**Contributors** (_roughly reverse cronological order_):
- Fabio Durastante
- Luca Pepè Sciarria
- Theophane Loloum
- Fabio Durastante
- Dimitri Walther
- Pasqua D'Ambra
- Andea Di Iorio
- Stefano Petrilli
- Soren Rasmussen
- Zaak Beekman
- Ambra Abdullahi Hassan
- Pasqua D'Ambra
- Alfredo Buttari
- Daniela di Serafino
- Thomas Amestoy
- Michele Martone
- Michele Colajanni
- Fabio Cerioni

@ -2,10 +2,13 @@ WHAT'S NEW
Version 3.9
1. PSBLAS3-EXT has been folded into the main library
2. Renamed GPU into CUDA.
3. Highly experimental OpenACC support.
3. Highly experimental OpenACC support. Requires a Fortran compiler which
supports SUBMODULES, e.g GNU Fortran version 12 or later
4. The iterative solvers are now defined in psb_linsolve_mod
and implemented in libpsb_linsolve.a; existing code using
Krylov methods will work with no changes.
Krylov methods will work with no changes.
5. In the linsolve directory we now have an interface for
Richardson interations
Version 3.8.0-2
1. CTXT is now an opaque object.

@ -1,9 +1,9 @@
set(PSB_base_source_files
comm/psb_dovrl_a.f90
comm/psb_dovrl.f90
# comm/psb_i2halo_a.f90
comm/psb_i2halo_a.f90
comm/internals/psi_zswaptran.F90
# comm/internals/psi_i2ovrl_upd_a.f90
comm/internals/psi_i2ovrl_upd_a.f90
comm/internals/psi_lovrl_save.f90
comm/internals/psi_movrl_save_a.f90
comm/internals/psi_sovrl_restr_a.f90
@ -16,7 +16,8 @@ set(PSB_base_source_files
comm/internals/psi_lovrl_upd.f90
comm/internals/psi_dswapdata_a.F90
comm/internals/psi_movrl_upd_a.f90
# comm/internals/psi_i2swaptran_a.F90
modules/comm/comm_schemes/psb_comm_rma_mod.F90
comm/internals/psi_i2swaptran_a.F90
comm/internals/psi_dswaptran.F90
comm/internals/psi_covrl_save_a.f90
comm/internals/psi_eovrl_restr_a.f90
@ -31,7 +32,7 @@ set(PSB_base_source_files
comm/internals/psi_sswaptran.F90
comm/internals/psi_lswaptran.F90
comm/internals/psi_mswaptran_a.F90
# comm/internals/psi_i2ovrl_restr_a.f90
comm/internals/psi_i2ovrl_restr_a.f90
comm/internals/psi_covrl_restr.f90
comm/internals/psi_mswapdata_a.F90
comm/internals/psi_zovrl_restr_a.f90
@ -49,14 +50,14 @@ set(PSB_base_source_files
comm/internals/psi_zswapdata_a.F90
comm/internals/psi_dovrl_save.f90
comm/internals/psi_covrl_save.f90
# comm/internals/psi_i2swapdata_a.F90
comm/internals/psi_i2swapdata_a.F90
comm/internals/psi_dovrl_upd.f90
comm/internals/psi_eovrl_save_a.f90
comm/internals/psi_zovrl_upd_a.f90
comm/internals/psi_zswapdata.F90
comm/internals/psi_covrl_upd.f90
comm/internals/psi_cswaptran.F90
# comm/internals/psi_i2ovrl_save_a.f90
comm/internals/psi_i2ovrl_save_a.f90
comm/internals/psi_sovrl_upd.f90
comm/internals/psi_eswapdata_a.F90
comm/internals/psi_movrl_restr_a.f90
@ -82,9 +83,9 @@ set(PSB_base_source_files
comm/psb_zhalo.f90
comm/psb_movrl_a.f90
comm/psb_chalo_a.f90
# comm/psb_i2scatter_a.F90
comm/psb_i2scatter_a.F90
comm/psb_sgather_a.f90
# comm/psb_i2ovrl_a.f90
comm/psb_i2ovrl_a.f90
comm/psb_zovrl_a.f90
comm/psb_covrl.f90
comm/psb_shalo.f90
@ -100,7 +101,7 @@ set(PSB_base_source_files
comm/psb_zhalo_a.f90
comm/psb_sscatter_a.F90
comm/psb_lscatter.F90
# comm/psb_i2gather_a.f90
comm/psb_i2gather_a.f90
comm/psb_ihalo.f90
comm/psb_iovrl.f90
comm/psb_zspgather.F90
@ -122,29 +123,29 @@ set(PSB_base_source_files
comm/psb_mgather_a.f90
comm/psb_dgather.f90
comm/psb_lhalo.f90
internals/psi_bld_glb_dep_list.F90
internals/psi_graph_fnd_owner.F90
internals/psi_sort_dl.f90
internals/psi_indx_map_fnd_owner.F90
internals/psi_fnd_owner.F90
internals/psi_bld_tmpovrl.f90
internals/psi_symm_dep_list.F90
internals/psi_desc_impl.f90
### internals/psi_compute_size.f90
internals/psi_hash_impl.f90
internals/psi_crea_ovr_elem.f90
internals/psi_a2a_fnd_owner.F90
internals/psi_bld_tmphalo.f90
internals/psi_crea_bnd_elem.f90
internals/psi_desc_index.F90
internals/psi_xtr_loc_dl.F90
internals/psi_crea_index.f90
internals/psi_srtlist.f90
internals/psi_adjcncy_fnd_owner.F90
auxil/psi_bld_glb_dep_list.F90
auxil/psi_graph_fnd_owner.F90
auxil/psi_sort_dl.f90
auxil/psi_indx_map_fnd_owner.F90
auxil/psi_fnd_owner.F90
auxil/psi_bld_tmpovrl.f90
auxil/psi_symm_dep_list.F90
auxil/psi_desc_impl.f90
### auxil/psi_compute_size.f90
auxil/psi_hash_impl.f90
auxil/psi_crea_ovr_elem.f90
auxil/psi_a2a_fnd_owner.F90
auxil/psi_bld_tmphalo.f90
auxil/psi_crea_bnd_elem.f90
auxil/psi_desc_index.F90
auxil/psi_xtr_loc_dl.F90
auxil/psi_crea_index.f90
auxil/psi_srtlist.f90
auxil/psi_adjcncy_fnd_owner.F90
tools/psb_sins.f90
tools/psb_zspasb.f90
tools/psb_zspalloc.f90
# tools/psb_i2_remote_vect.F90
tools/psb_i2_remote_vect.F90
tools/psb_sfree_a.f90
tools/psb_cdprt.f90
tools/psb_c_glob_transpose.F90
@ -160,7 +161,7 @@ set(PSB_base_source_files
tools/psb_zallc_a.f90
tools/psb_d_map.f90
tools/psb_lfree.f90
# tools/psb_i2ins_a.f90
tools/psb_i2ins_a.f90
tools/psb_s_remap.F90
tools/psb_cspalloc.f90
tools/psb_glob_to_loc.f90
@ -177,9 +178,9 @@ set(PSB_base_source_files
tools/psb_sgetelem.f90
tools/psb_cspfree.f90
tools/psb_cins.f90
# tools/psb_i2free_a.f90
tools/psb_i2free_a.f90
tools/psb_dspins.F90
# tools/psb_i2asb_a.f90
tools/psb_i2asb_a.f90
tools/psb_dsphalo.F90
tools/psb_d_glob_transpose.F90
tools/psb_c_par_csr_spspmm.f90
@ -265,14 +266,18 @@ set(PSB_base_source_files
tools/psb_zspins.F90
tools/psb_zins_a.f90
tools/psb_cdcpy.F90
# tools/psb_i2allc_a.f90
tools/psb_i2allc_a.f90
tools/psb_dallc.f90
tools/psb_cd_renum_block.F90
tools/psb_dasb_a.f90
tools/psb_zsprn.f90
tools/psb_get_overlap.f90
serial/psb_crwextd.f90
serial/psb_zspspmm.f90
serial/psb_saplusat.f90
serial/psb_daplusat.f90
serial/psb_caplusat.f90
serial/psb_zaplusat.f90
serial/psb_crwextd.f90
serial/psb_zspspmm.F90
serial/psb_drwextd.f90
serial/psb_dnumbmm.f90
serial/psb_damax_s.f90
@ -343,14 +348,14 @@ set(PSB_base_source_files
serial/psb_dsymbmm.f90
serial/psb_samax_s.f90
serial/psb_lsame.f90
serial/psb_dspspmm.f90
serial/psb_dspspmm.F90
serial/psb_ssymbmm.f90
serial/psb_cgeprt.f90
serial/psb_sgeprt.f90
# serial/psi_i2_serial_impl.F90
serial/psi_i2_serial_impl.F90
serial/psi_e_serial_impl.F90
serial/psb_zsymbmm.f90
serial/psb_cspspmm.f90
serial/psb_cspspmm.F90
serial/psb_aspxpby.f90
serial/psi_s_serial_impl.F90
serial/psb_zamax_s.f90
@ -359,7 +364,7 @@ set(PSB_base_source_files
serial/psb_casum_s.f90
serial/psi_d_serial_impl.F90
serial/psi_c_serial_impl.F90
serial/psb_sspspmm.f90
serial/psb_sspspmm.F90
serial/psb_cnumbmm.f90
psblas/psb_damax.f90
psblas/psb_dspmm.f90
@ -426,14 +431,15 @@ set(PSB_base_source_files
psblas/psb_cinv_vect.f90
psblas/psb_zasum.f90
modules/comm/psi_z_comm_v_mod.f90
# modules/comm/psb_i2_comm_a_mod.f90
modules/comm/psb_m_comm_a_mod.f90
modules/comm/psb_m_comm_a_mod.f90
modules/comm/psb_z_linmap_mod.f90
modules/comm/psi_s_comm_a_mod.f90
# modules/comm/psi_i2_comm_a_mod.f90
modules/comm/psb_i2_comm_a_mod.f90
modules/comm/psi_i2_comm_a_mod.f90
modules/comm/psi_i2_comm_v_mod.f90
modules/comm/psi_m_comm_a_mod.f90
modules/comm/psi_l_comm_v_mod.f90
modules/comm/psb_comm_mod.f90
modules/comm/psb_comm_mod.F90
modules/comm/psb_l_comm_mod.f90
modules/comm/psb_d_linmap_mod.f90
modules/comm/psi_d_comm_v_mod.f90
@ -458,7 +464,7 @@ set(PSB_base_source_files
modules/comm/psb_linmap_mod.f90
modules/comm/psb_z_comm_a_mod.f90
modules/comm/psi_c_comm_a_mod.f90
# modules/auxil/psb_i2_isort_mod.f90
modules/auxil/psb_i2_isort_mod.f90
modules/auxil/psb_z_ip_reord_mod.F90
modules/auxil/psi_s_serial_mod.f90
modules/auxil/psb_s_hsort_x_mod.f90
@ -466,7 +472,7 @@ set(PSB_base_source_files
modules/auxil/psb_d_hsort_mod.f90
modules/auxil/psi_alcx_mod.f90
modules/auxil/psb_e_ip_reord_mod.F90
# modules/auxil/psb_i2_msort_mod.f90
modules/auxil/psb_i2_msort_mod.f90
modules/auxil/psb_rb_idx_tree_mod.f90
modules/auxil/psb_m_isort_mod.f90
modules/auxil/psb_e_msort_mod.f90
@ -485,14 +491,15 @@ set(PSB_base_source_files
modules/auxil/psb_z_isort_mod.f90
modules/auxil/psb_e_hsort_mod.f90
modules/auxil/psi_m_serial_mod.f90
# modules/auxil/psi_i2_serial_mod.f90
modules/auxil/psi_i2_serial_mod.f90
modules/auxil/psb_i2_hsort_x_mod.f90
modules/auxil/psb_s_isort_mod.f90
modules/auxil/psb_e_realloc_mod.F90
modules/auxil/psb_c_hsort_mod.f90
modules/auxil/psb_z_msort_mod.f90
modules/auxil/psi_d_serial_mod.f90
modules/auxil/psb_z_qsort_mod.f90
# modules/auxil/psb_i2_hsort_mod.f90
modules/auxil/psb_i2_hsort_mod.f90
modules/auxil/psb_m_msort_mod.f90
modules/auxil/psb_m_ip_reord_mod.F90
modules/auxil/psb_string_mod.f90
@ -505,14 +512,14 @@ set(PSB_base_source_files
modules/auxil/psb_m_hsort_mod.f90
modules/auxil/psb_z_realloc_mod.F90
modules/auxil/psb_z_rb_idx_tree_mod.f90
# modules/auxil/psb_i2_ip_reord_mod.F90
# modules/auxil/psb_i2_realloc_mod.F90
modules/auxil/psb_i2_ip_reord_mod.F90
modules/auxil/psb_i2_realloc_mod.F90
modules/auxil/psb_s_rb_idx_tree_mod.f90
modules/auxil/psb_c_hsort_x_mod.f90
modules/auxil/psb_s_ip_reord_mod.F90
modules/auxil/psb_d_isort_mod.f90
modules/auxil/psi_z_serial_mod.f90
# modules/auxil/psb_i2_qsort_mod.f90
modules/auxil/psb_i2_qsort_mod.f90
modules/auxil/psb_d_msort_mod.f90
modules/auxil/psb_c_qsort_mod.f90
modules/auxil/psb_z_hsort_x_mod.f90
@ -529,7 +536,7 @@ set(PSB_base_source_files
modules/psi_l_mod.F90
modules/penv/psi_d_collective_mod.F90
modules/penv/psi_m_p2p_mod.F90
# modules/penv/psi_i2_collective_mod.F90
modules/penv/psi_i2_collective_mod.F90
modules/penv/psi_s_p2p_mod.F90
modules/penv/psi_e_p2p_mod.F90
modules/penv/psi_m_collective_mod.F90
@ -539,7 +546,7 @@ set(PSB_base_source_files
modules/penv/psi_z_p2p_mod.F90
modules/penv/psi_c_collective_mod.F90
modules/penv/psi_collective_mod.F90
# modules/penv/psi_i2_p2p_mod.F90
modules/penv/psi_i2_p2p_mod.F90
modules/penv/psi_c_p2p_mod.F90
modules/penv/psi_e_collective_mod.F90
modules/penv/psi_z_collective_mod.F90
@ -558,7 +565,7 @@ set(PSB_base_source_files
modules/tools/psb_d_tools_mod.F90
modules/tools/psb_c_tools_mod.F90
modules/tools/psb_e_tools_a_mod.f90
# modules/tools/psb_i2_tools_a_mod.f90
modules/tools/psb_i2_tools_a_mod.f90
modules/tools/psb_c_tools_a_mod.f90
modules/tools/psb_z_tools_mod.F90
modules/tools/psb_l_tools_mod.F90
@ -584,6 +591,7 @@ set(PSB_base_source_files
modules/serial/psb_s_base_mat_mod.F90
modules/serial/psb_base_mat_mod.F90
modules/serial/psb_i_base_vect_mod.F90
modules/serial/psb_i2_base_vect_mod.F90
modules/serial/psb_s_vect_mod.F90
modules/serial/psb_s_base_vect_mod.F90
modules/serial/psb_d_base_vect_mod.F90
@ -592,7 +600,8 @@ set(PSB_base_source_files
modules/serial/psb_c_vect_mod.F90
modules/serial/psb_d_mat_mod.F90
modules/serial/psb_s_mat_mod.F90
modules/serial/psb_i_vect_mod.F90
modules/serial/psb_i2_vect_mod.F90
modules/serial/psb_i_vect_mod.F90
modules/serial/psb_d_vect_mod.F90
modules/serial/psb_c_base_vect_mod.F90
modules/serial/psb_vect_mod.f90
@ -612,6 +621,7 @@ set(PSB_base_source_files
modules/psb_penv_mod.F90
modules/psb_error_mod.F90
modules/psb_timers_mod.f90
modules/psi_i2_mod.F90
modules/psi_i_mod.F90
modules/psi_z_mod.F90
modules/desc/psb_desc_const_mod.f90

@ -6,18 +6,18 @@ INCDIR=../include
MODDIR=../modules
LIBNAME=$(BASELIBNAME)
objs: mods sr cm in pb tl
objs: mods sr cm ax pb tl
lib: objs
$(MAKE) -C modules lib LIBNAME=$(BASELIBNAME) F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
$(MAKE) -C serial lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C comm lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C internals lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C auxil lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C psblas lib LIBNAME=$(BASELIBNAME)
$(MAKE) -C tools lib LIBNAME=$(BASELIBNAME)
/bin/cp -p $(CPUPDFLAG) $(HERE)/$(LIBNAME) $(LIBDIR)
sr cm in pb tl: mods
sr cm ax pb tl: mods
mods:
$(MAKE) -C modules objs F90="$(MPF90)" F90COPT="$(F90COPT) $(MPI_OPT)"
@ -25,8 +25,8 @@ sr:
$(MAKE) -C serial objs
cm:
$(MAKE) -C comm objs
in:
$(MAKE) -C internals objs
ax:
$(MAKE) -C auxil objs
pb:
$(MAKE) -C psblas objs
tl:
@ -35,7 +35,7 @@ tl:
clean:
($(MAKE) -C modules clean)
($(MAKE) -C comm clean)
($(MAKE) -C internals clean)
($(MAKE) -C auxil clean)
($(MAKE) -C tools clean)
($(MAKE) -C serial clean)
($(MAKE) -C psblas clean)

@ -16,7 +16,7 @@ MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
CINCLUDES=-I.
objs: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(MPFOBJS)
objs: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -90,7 +90,7 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize)
call psb_erractionsave(err_act)
ctxt = idxmap%get_ctxt()
icomm = idxmap%get_mpic()
icomm = ctxt%get_mpic()
mglob = idxmap%get_gr()
n_row = idxmap%get_lr()
n_col = idxmap%get_lc()

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -100,7 +100,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
call psb_erractionsave(err_act)
ctxt = idxmap%get_ctxt()
icomm = idxmap%get_mpic()
icomm = ctxt%get_mpic()
mglob = idxmap%get_gr()
n_row = idxmap%get_lr()
n_col = idxmap%get_lc()

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -71,7 +71,7 @@ subroutine psi_bld_tmphalo(desc,info)
call psb_erractionsave(err_act)
ctxt = desc%get_context()
icomm = desc%get_mpic()
icomm = ctxt%get_mpic()
n_row = desc%get_local_rows()
n_col = desc%get_local_cols()

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -78,7 +78,7 @@ subroutine psi_i_bld_tmpovrl(iv,desc,info)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt = desc%get_context()
icomm = desc%get_mpic()
icomm = ctxt%get_mpic()
! check on blacs grid
call psb_info(ctxt, me, np)

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -151,7 +151,7 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
debug_level = psb_get_debug_level()
ctxt = desc%get_context()
icomm = desc%get_mpic()
icomm = ctxt%get_mpic()
call psb_info(ctxt,me,np)
if (np == -1) then
info = psb_err_context_error_

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -85,7 +85,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
call psb_erractionsave(err_act)
ctxt = desc%get_context()
icomm = desc%get_mpic()
icomm = ctxt%get_mpic()
n_row = desc%get_local_rows()
n_col = desc%get_local_cols()

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -121,7 +121,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,ladj,idxmap,info)
call psb_erractionsave(err_act)
ctxt = idxmap%get_ctxt()
icomm = idxmap%get_mpic()
icomm = ctxt%get_mpic()
mglob = idxmap%get_gr()
n_row = idxmap%get_lr()
n_col = idxmap%get_lc()

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -88,7 +88,7 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info,adj)
call psb_erractionsave(err_act)
ctxt = idxmap%get_ctxt()
icomm = idxmap%get_mpic()
icomm = ctxt%get_mpic()
mglob = idxmap%get_gr()
call psb_info(ctxt, me, np)

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -8,6 +8,7 @@ OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \
psb_zgather.o psb_zhalo.o psb_zovrl.o \
psb_dgather_a.o psb_dhalo_a.o psb_dovrl_a.o \
psb_sgather_a.o psb_shalo_a.o psb_sovrl_a.o \
psb_i2gather_a.o psb_i2halo_a.o psb_i2ovrl_a.o \
psb_mgather_a.o psb_mhalo_a.o psb_movrl_a.o \
psb_egather_a.o psb_ehalo_a.o psb_eovrl_a.o \
psb_cgather_a.o psb_chalo_a.o psb_covrl_a.o \
@ -18,7 +19,7 @@ MPFOBJS=psb_dscatter.o psb_zscatter.o \
psb_iscatter.o psb_lscatter.o \
psb_cscatter.o psb_sscatter.o \
psb_dscatter_a.o psb_zscatter_a.o \
psb_mscatter_a.o psb_escatter_a.o \
psb_mscatter_a.o psb_escatter_a.o psb_i2scatter_a.o \
psb_cscatter_a.o psb_sscatter_a.o \
psb_dspgather.o psb_sspgather.o \
psb_zspgather.o psb_cspgather.o

@ -6,6 +6,7 @@ FOBJS = psi_iovrl_restr.o psi_iovrl_save.o psi_iovrl_upd.o \
psi_dovrl_restr.o psi_dovrl_save.o psi_dovrl_upd.o \
psi_covrl_restr.o psi_covrl_save.o psi_covrl_upd.o \
psi_zovrl_restr.o psi_zovrl_save.o psi_zovrl_upd.o \
psi_i2ovrl_restr_a.o psi_i2ovrl_save_a.o psi_i2ovrl_upd_a.o \
psi_movrl_restr_a.o psi_movrl_save_a.o psi_movrl_upd_a.o \
psi_eovrl_restr_a.o psi_eovrl_save_a.o psi_eovrl_upd_a.o \
psi_sovrl_restr_a.o psi_sovrl_save_a.o psi_sovrl_upd_a.o \
@ -21,6 +22,7 @@ MPFOBJS = psi_dswapdata.o psi_dswaptran.o\
psi_zswapdata.o psi_zswaptran.o \
psi_dswapdata_a.o psi_dswaptran_a.o \
psi_sswapdata_a.o psi_sswaptran_a.o \
psi_i2swapdata_a.o psi_i2swaptran_a.o \
psi_mswapdata_a.o psi_mswaptran_a.o \
psi_eswapdata_a.o psi_eswaptran_a.o \
psi_cswapdata_a.o psi_cswaptran_a.o \
@ -31,16 +33,16 @@ MODDIR=../../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
CINCLUDES=-I.
objs: mpfobjs $(FOBJS) $(MPFOBJS)
objs: mpfobjs $(FOBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
$(FOBJS) $(FBOJS2): $(MODDIR)/psi_mod.o
mpfobjs:
(make $(MPFOBJS) FC="$(MPFC)" )
mpfobjs: $(MODDIR)/psi_mod.o
(make $(MPFOBJS) FC="$(MPFC)" )
clean:
/bin/rm -f $(MPFOBJS) $(FOBJS) $(COBJS) $(FOBJS2) $(MPFOBJS2) *$(.mod)
/bin/rm -f $(MPFOBJS) $(FOBJS) $(COBJS) $(FOBJS2) $(MPFOBJS2) *$(.mod) *.smod
veryclean: clean

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -35,90 +35,90 @@
!
!
!
subroutine psi_covrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restr_vect
use psb_c_base_vect_mod
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_covrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_v_mod) psi_c_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_covrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_covrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restr_vect
return
end subroutine psi_covrl_restr_vect
subroutine psi_covrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restr_multivect
use psb_c_base_vect_mod
module subroutine psi_covrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_c_base_multivect_type) :: x
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: x
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_covrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_covrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restr_multivect
return
end subroutine psi_covrl_restr_multivect
end submodule psi_c_ovrl_restr_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_covrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restrr1
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_a_mod) psi_c_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_covrl_restrr1(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restrr1
return
end subroutine psi_covrl_restrr1
subroutine psi_covrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restrr2
module subroutine psi_covrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_covrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restrr2
return
end subroutine psi_covrl_restrr2
end submodule psi_c_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_covrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_save_vect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_v_mod) psi_c_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_covrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_save_vect
subroutine psi_covrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_save_multivect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_multivect_type) :: x
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_covrl_save_vect
module subroutine psi_covrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_c_base_multivect_type) :: x
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_save_multivect
return
end subroutine psi_covrl_save_multivect
end submodule psi_c_ovrl_save_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_covrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_saver1
use psb_realloc_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_a_mod) psi_c_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_covrl_saver1(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_saver1
subroutine psi_covrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_saver2
use psb_realloc_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_covrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_covrl_saver1
module subroutine psi_covrl_saver2(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_covrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_saver2
return
end subroutine psi_covrl_saver2
end submodule psi_c_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -36,169 +36,167 @@
!
!
!
subroutine psi_covrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_upd_vect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_c_comm_v_mod) psi_c_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_covrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_c_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_upd_vect
subroutine psi_covrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_upd_multivect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_covrl_upd_vect
module subroutine psi_covrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_c_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_upd_multivect
return
end subroutine psi_covrl_upd_multivect
end submodule psi_c_ovrl_upd_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_covrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_covrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_updr1
implicit none
complex(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_a_mod) psi_c_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_covrl_updr1(x,desc_a,update,info)
implicit none
complex(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_updr1
subroutine psi_covrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_updr2
implicit none
complex(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_covrl_updr1
module subroutine psi_covrl_updr2(x,desc_a,update,info)
implicit none
complex(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_updr2
return
end subroutine psi_covrl_updr2
end submodule psi_c_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -35,90 +35,90 @@
!
!
!
subroutine psi_dovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restr_vect
use psb_d_base_vect_mod
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_v_mod) psi_d_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_dovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restr_vect
return
end subroutine psi_dovrl_restr_vect
subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restr_multivect
use psb_d_base_vect_mod
module subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_d_base_multivect_type) :: x
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: x
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_dovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restr_multivect
return
end subroutine psi_dovrl_restr_multivect
end submodule psi_d_ovrl_restr_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_dovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restrr1
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_a_mod) psi_d_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_dovrl_restrr1(x,xs,desc_a,info)
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restrr1
return
end subroutine psi_dovrl_restrr1
subroutine psi_dovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restrr2
module subroutine psi_dovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_dovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restrr2
return
end subroutine psi_dovrl_restrr2
end submodule psi_d_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_dovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_save_vect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_v_mod) psi_d_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_dovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_save_vect
subroutine psi_dovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_save_multivect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_multivect_type) :: x
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_dovrl_save_vect
module subroutine psi_dovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_d_base_multivect_type) :: x
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_save_multivect
return
end subroutine psi_dovrl_save_multivect
end submodule psi_d_ovrl_save_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_dovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_saver1
use psb_realloc_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_a_mod) psi_d_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_dovrl_saver1(x,xs,desc_a,info)
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_saver1
subroutine psi_dovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_saver2
use psb_realloc_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_dovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_dovrl_saver1
module subroutine psi_dovrl_saver2(x,xs,desc_a,info)
implicit none
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_dovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_saver2
return
end subroutine psi_dovrl_saver2
end submodule psi_d_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -36,169 +36,167 @@
!
!
!
subroutine psi_dovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_upd_vect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_d_comm_v_mod) psi_d_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_dovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_d_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_upd_vect
subroutine psi_dovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_upd_multivect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_dovrl_upd_vect
module subroutine psi_dovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_d_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_upd_multivect
return
end subroutine psi_dovrl_upd_multivect
end submodule psi_d_ovrl_upd_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_dovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_dovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_updr1
implicit none
real(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_a_mod) psi_d_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_dovrl_updr1(x,desc_a,update,info)
implicit none
real(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_updr1
subroutine psi_dovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_updr2
implicit none
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_dovrl_updr1
module subroutine psi_dovrl_updr2(x,desc_a,update,info)
implicit none
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_updr2
return
end subroutine psi_dovrl_updr2
end submodule psi_d_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_eovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_restrr1
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_e_comm_a_mod) psi_e_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_eovrl_restrr1(x,xs,desc_a,info)
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_restrr1
return
end subroutine psi_eovrl_restrr1
subroutine psi_eovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_restrr2
module subroutine psi_eovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_eovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_restrr2
return
end subroutine psi_eovrl_restrr2
end submodule psi_e_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_eovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_saver1
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_e_comm_a_mod) psi_e_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_eovrl_saver1(x,xs,desc_a,info)
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_saver1
subroutine psi_eovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_saver2
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_eovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_eovrl_saver1
module subroutine psi_eovrl_saver2(x,xs,desc_a,info)
implicit none
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_eovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_saver2
return
end subroutine psi_eovrl_saver2
end submodule psi_e_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_eovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_eovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_eovrl_updr1
implicit none
integer(psb_epk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_e_comm_a_mod) psi_e_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_eovrl_updr1(x,desc_a,update,info)
implicit none
integer(psb_epk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_updr1
subroutine psi_eovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_eovrl_updr2
implicit none
integer(psb_epk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_eovrl_updr1
module subroutine psi_eovrl_updr2(x,desc_a,update,info)
implicit none
integer(psb_epk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_updr2
return
end subroutine psi_eovrl_updr2
end submodule psi_e_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_restrr1
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_i2_comm_a_mod) psi_i2_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_restrr1
return
end subroutine psi_i2ovrl_restrr1
subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_restrr2
module subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_i2ovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_restrr2
return
end subroutine psi_i2ovrl_restrr2
end submodule psi_i2_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_saver1
use psb_realloc_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_i2_comm_a_mod) psi_i2_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_saver1
subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_saver2
use psb_realloc_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_i2ovrl_saver1
module subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_saver2
return
end subroutine psi_i2ovrl_saver2
end submodule psi_i2_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_i2ovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_i2ovrl_updr1
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_i2_comm_a_mod) psi_i2_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_updr1
subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_i2ovrl_updr2
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_i2ovrl_updr1
module subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_updr2
return
end subroutine psi_i2ovrl_updr2
end submodule psi_i2_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -35,90 +35,90 @@
!
!
!
subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_restr_vect
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_iovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
submodule (psi_i_comm_v_mod) psi_i_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_iovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_restr_vect
return
end subroutine psi_iovrl_restr_vect
subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_restr_multivect
use psb_i_base_vect_mod
module subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_iovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_iovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_restr_multivect
return
end subroutine psi_iovrl_restr_multivect
end submodule psi_i_ovrl_restr_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_save_vect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_i_comm_v_mod) psi_i_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_save_vect
subroutine psi_iovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_save_multivect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_iovrl_save_vect
module subroutine psi_iovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_save_multivect
return
end subroutine psi_iovrl_save_multivect
end submodule psi_i_ovrl_save_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -36,169 +36,167 @@
!
!
!
subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_iovrl_upd_vect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_i_comm_v_mod) psi_i_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_upd_vect
subroutine psi_iovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_iovrl_upd_multivect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_iovrl_upd_vect
module subroutine psi_iovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_i_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_upd_multivect
return
end subroutine psi_iovrl_upd_multivect
end submodule psi_i_ovrl_upd_v_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -35,90 +35,90 @@
!
!
!
subroutine psi_lovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_restr_vect
use psb_l_base_vect_mod
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_lovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
call psb_erractionrestore(err_act)
return
submodule (psi_l_comm_v_mod) psi_l_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_lovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_lovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_restr_vect
return
end subroutine psi_lovrl_restr_vect
subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_restr_multivect
use psb_l_base_vect_mod
module subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_lovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_lovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_restr_multivect
return
end subroutine psi_lovrl_restr_multivect
end submodule psi_l_ovrl_restr_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_lovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_save_vect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_l_comm_v_mod) psi_l_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_lovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_save_vect
subroutine psi_lovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_save_multivect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_lovrl_save_vect
module subroutine psi_lovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_save_multivect
return
end subroutine psi_lovrl_save_multivect
end submodule psi_l_ovrl_save_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -36,169 +36,167 @@
!
!
!
subroutine psi_lovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_lovrl_upd_vect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_l_comm_v_mod) psi_l_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_lovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_l_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_upd_vect
subroutine psi_lovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_lovrl_upd_multivect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_lovrl_upd_vect
module subroutine psi_lovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_l_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_upd_multivect
return
end subroutine psi_lovrl_upd_multivect
end submodule psi_l_ovrl_upd_v_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_movrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_restrr1
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_m_comm_a_mod) psi_m_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_movrl_restrr1(x,xs,desc_a,info)
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_restrr1
return
end subroutine psi_movrl_restrr1
subroutine psi_movrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_restrr2
module subroutine psi_movrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_movrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_restrr2
return
end subroutine psi_movrl_restrr2
end submodule psi_m_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_movrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_saver1
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_m_comm_a_mod) psi_m_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_movrl_saver1(x,xs,desc_a,info)
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_saver1
subroutine psi_movrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_saver2
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_movrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_movrl_saver1
module subroutine psi_movrl_saver2(x,xs,desc_a,info)
implicit none
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_movrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_saver2
return
end subroutine psi_movrl_saver2
end submodule psi_m_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_movrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_movrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_movrl_updr1
implicit none
integer(psb_mpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_m_comm_a_mod) psi_m_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_movrl_updr1(x,desc_a,update,info)
implicit none
integer(psb_mpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_updr1
subroutine psi_movrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_movrl_updr2
implicit none
integer(psb_mpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_movrl_updr1
module subroutine psi_movrl_updr2(x,desc_a,update,info)
implicit none
integer(psb_mpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_updr2
return
end subroutine psi_movrl_updr2
end submodule psi_m_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -35,90 +35,90 @@
!
!
!
subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restr_vect
use psb_s_base_vect_mod
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_sovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_v_mod) psi_s_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_sovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restr_vect
return
end subroutine psi_sovrl_restr_vect
subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restr_multivect
use psb_s_base_vect_mod
module subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_s_base_multivect_type) :: x
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: x
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_sovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_sovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restr_multivect
return
end subroutine psi_sovrl_restr_multivect
end submodule psi_s_ovrl_restr_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_sovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restrr1
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_a_mod) psi_s_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_sovrl_restrr1(x,xs,desc_a,info)
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restrr1
return
end subroutine psi_sovrl_restrr1
subroutine psi_sovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restrr2
module subroutine psi_sovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_sovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restrr2
return
end subroutine psi_sovrl_restrr2
end submodule psi_s_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_save_vect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_v_mod) psi_s_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_save_vect
subroutine psi_sovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_save_multivect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_multivect_type) :: x
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_sovrl_save_vect
module subroutine psi_sovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_s_base_multivect_type) :: x
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_save_multivect
return
end subroutine psi_sovrl_save_multivect
end submodule psi_s_ovrl_save_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_sovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_saver1
use psb_realloc_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_a_mod) psi_s_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_sovrl_saver1(x,xs,desc_a,info)
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_saver1
subroutine psi_sovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_saver2
use psb_realloc_mod
implicit none
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_sovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_sovrl_saver1
module subroutine psi_sovrl_saver2(x,xs,desc_a,info)
implicit none
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_sovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_saver2
return
end subroutine psi_sovrl_saver2
end submodule psi_s_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -36,169 +36,167 @@
!
!
!
subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_upd_vect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_s_comm_v_mod) psi_s_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_s_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_upd_vect
subroutine psi_sovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_upd_multivect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_sovrl_upd_vect
module subroutine psi_sovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_s_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_upd_multivect
return
end subroutine psi_sovrl_upd_multivect
end submodule psi_s_ovrl_upd_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_sovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_sovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_updr1
implicit none
real(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_a_mod) psi_s_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_sovrl_updr1(x,desc_a,update,info)
implicit none
real(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_updr1
subroutine psi_sovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_updr2
implicit none
real(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_sovrl_updr1
module subroutine psi_sovrl_updr2(x,desc_a,update,info)
implicit none
real(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_updr2
return
end subroutine psi_sovrl_updr2
end submodule psi_s_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -35,90 +35,90 @@
!
!
!
subroutine psi_zovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restr_vect
use psb_z_base_vect_mod
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_zovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_v_mod) psi_z_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_zovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_zovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restr_vect
return
end subroutine psi_zovrl_restr_vect
subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restr_multivect
use psb_z_base_vect_mod
module subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_zovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_zovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restr_multivect
return
end subroutine psi_zovrl_restr_multivect
end submodule psi_z_ovrl_restr_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restrr1
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_a_mod) psi_z_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restrr1
return
end subroutine psi_zovrl_restrr1
subroutine psi_zovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restrr2
module subroutine psi_zovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_zovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restrr2
return
end subroutine psi_zovrl_restrr2
end submodule psi_z_ovrl_restr_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_zovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_save_vect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_v_mod) psi_z_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_zovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_save_vect
subroutine psi_zovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_save_multivect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_zovrl_save_vect
module subroutine psi_zovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_save_multivect
return
end subroutine psi_zovrl_save_multivect
end submodule psi_z_ovrl_save_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_zovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_saver1
use psb_realloc_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_a_mod) psi_z_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_zovrl_saver1(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_saver1
subroutine psi_zovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_saver2
use psb_realloc_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_zovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_zovrl_saver1
module subroutine psi_zovrl_saver2(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_zovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_saver2
return
end subroutine psi_zovrl_saver2
end submodule psi_z_ovrl_save_a_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -36,169 +36,167 @@
!
!
!
subroutine psi_zovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_upd_vect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_z_comm_v_mod) psi_z_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_zovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_z_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_upd_vect
subroutine psi_zovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_upd_multivect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_zovrl_upd_vect
module subroutine psi_zovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_z_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_upd_multivect
return
end subroutine psi_zovrl_upd_multivect
end submodule psi_z_ovrl_upd_v_impl

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -32,143 +32,143 @@
! Subroutine: psi_zovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_zovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_updr1
implicit none
complex(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_a_mod) psi_z_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_zovrl_updr1(x,desc_a,update,info)
implicit none
complex(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_updr1
subroutine psi_zovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_updr2
implicit none
complex(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_zovrl_updr1
module subroutine psi_zovrl_updr2(x,desc_a,update,info)
implicit none
complex(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_updr2
return
end subroutine psi_zovrl_updr2
end submodule psi_z_ovrl_upd_a_impl

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

@ -14,7 +14,7 @@
! 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.
! software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
@ -189,7 +189,7 @@ end subroutine psb_cgatherm
!!$ 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.
!!$ software without specific prior written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save