diff --git a/base/modules/auxil/psi_c_serial_mod.f90 b/base/modules/auxil/psi_c_serial_mod.f90 index 5dc25dc44..05145c1c9 100644 --- a/base/modules/auxil/psi_c_serial_mod.f90 +++ b/base/modules/auxil/psi_c_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_c_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_ @@ -36,7 +36,7 @@ module psi_c_serial_mod ! 2-D version subroutine psb_cgelp(trans,iperm,x,info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none complex(psb_spk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_c_serial_mod end subroutine psb_cgelp subroutine psb_cgelpv(trans,iperm,x,info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_cgelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_caxpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n complex(psb_spk_), intent (in) :: x(:,:) complex(psb_spk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_c_serial_mod end subroutine psi_caxpby subroutine psi_caxpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent (in) :: x(:) complex(psb_spk_), intent (inout) :: y(:) complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_caxpbyv + subroutine psi_caxpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent (in) :: x(:) + complex(psb_spk_), intent (in) :: y(:) + complex(psb_spk_), intent (in) :: z(:) + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_caxpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_c_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) complex(psb_spk_) :: x(:,:), y(:) - + end subroutine psi_cgthzmv subroutine psi_cgthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_spk_ implicit none integer(psb_ipk_) :: n, k, idx(:) complex(psb_spk_) :: x(:,:), y(:,:) - + end subroutine psi_cgthzmm subroutine psi_cgthzv(n,idx,x,y) import :: psb_ipk_, psb_spk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: x(:), y(:) end subroutine psi_cgthzv @@ -124,7 +134,7 @@ module psi_c_serial_mod subroutine psi_csctv(n,idx,x,beta,y) import :: psb_ipk_, psb_spk_ implicit none - + integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:), y(:) end subroutine psi_csctv diff --git a/base/modules/auxil/psi_d_serial_mod.f90 b/base/modules/auxil/psi_d_serial_mod.f90 index 541446c70..0bea1bce5 100644 --- a/base/modules/auxil/psi_d_serial_mod.f90 +++ b/base/modules/auxil/psi_d_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_d_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_dpk_ @@ -36,7 +36,7 @@ module psi_d_serial_mod ! 2-D version subroutine psb_dgelp(trans,iperm,x,info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none real(psb_dpk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_d_serial_mod end subroutine psb_dgelp subroutine psb_dgelpv(trans,iperm,x,info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none real(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_dgelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_daxpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n real(psb_dpk_), intent (in) :: x(:,:) real(psb_dpk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_d_serial_mod end subroutine psi_daxpby subroutine psi_daxpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent (in) :: x(:) real(psb_dpk_), intent (inout) :: y(:) real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_daxpbyv + subroutine psi_daxpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent (in) :: x(:) + real(psb_dpk_), intent (in) :: y(:) + real(psb_dpk_), intent (in) :: z(:) + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_daxpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_d_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) real(psb_dpk_) :: x(:,:), y(:) - + end subroutine psi_dgthzmv subroutine psi_dgthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_dpk_ implicit none integer(psb_ipk_) :: n, k, idx(:) real(psb_dpk_) :: x(:,:), y(:,:) - + end subroutine psi_dgthzmm subroutine psi_dgthzv(n,idx,x,y) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: x(:), y(:) end subroutine psi_dgthzv @@ -124,7 +134,7 @@ module psi_d_serial_mod subroutine psi_dsctv(n,idx,x,beta,y) import :: psb_ipk_, psb_dpk_ implicit none - + integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:), y(:) end subroutine psi_dsctv diff --git a/base/modules/auxil/psi_e_serial_mod.f90 b/base/modules/auxil/psi_e_serial_mod.f90 index f95d812b4..f8b9694db 100644 --- a/base/modules/auxil/psi_e_serial_mod.f90 +++ b/base/modules/auxil/psi_e_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_e_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ @@ -36,7 +36,7 @@ module psi_e_serial_mod ! 2-D version subroutine psb_egelp(trans,iperm,x,info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_epk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_e_serial_mod end subroutine psb_egelp subroutine psb_egelpv(trans,iperm,x,info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_epk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_egelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n integer(psb_epk_), intent (in) :: x(:,:) integer(psb_epk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_e_serial_mod end subroutine psi_eaxpby subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m integer(psb_epk_), intent (in) :: x(:) integer(psb_epk_), intent (inout) :: y(:) integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_eaxpbyv + subroutine psi_eaxpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_epk_), intent (in) :: x(:) + integer(psb_epk_), intent (in) :: y(:) + integer(psb_epk_), intent (in) :: z(:) + integer(psb_epk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eaxpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_e_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) integer(psb_epk_) :: x(:,:), y(:) - + end subroutine psi_egthzmv subroutine psi_egthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) integer(psb_epk_) :: x(:,:), y(:,:) - + end subroutine psi_egthzmm subroutine psi_egthzv(n,idx,x,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_epk_) :: x(:), y(:) end subroutine psi_egthzv @@ -124,7 +134,7 @@ module psi_e_serial_mod subroutine psi_esctv(n,idx,x,beta,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none - + integer(psb_ipk_) :: n, idx(:) integer(psb_epk_) :: beta, x(:), y(:) end subroutine psi_esctv diff --git a/base/modules/auxil/psi_i2_serial_mod.f90 b/base/modules/auxil/psi_i2_serial_mod.f90 index fd71ea842..bc0df7c55 100644 --- a/base/modules/auxil/psi_i2_serial_mod.f90 +++ b/base/modules/auxil/psi_i2_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_i2_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ @@ -36,7 +36,7 @@ module psi_i2_serial_mod ! 2-D version subroutine psb_i2gelp(trans,iperm,x,info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_i2pk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_i2_serial_mod end subroutine psb_i2gelp subroutine psb_i2gelpv(trans,iperm,x,info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_i2pk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_i2gelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n integer(psb_i2pk_), intent (in) :: x(:,:) integer(psb_i2pk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_i2_serial_mod end subroutine psi_i2axpby subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m integer(psb_i2pk_), intent (in) :: x(:) integer(psb_i2pk_), intent (inout) :: y(:) integer(psb_i2pk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_i2axpbyv + subroutine psi_i2axpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_i2pk_), intent (in) :: x(:) + integer(psb_i2pk_), intent (in) :: y(:) + integer(psb_i2pk_), intent (in) :: z(:) + integer(psb_i2pk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i2axpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_i2_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) integer(psb_i2pk_) :: x(:,:), y(:) - + end subroutine psi_i2gthzmv subroutine psi_i2gthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) integer(psb_i2pk_) :: x(:,:), y(:,:) - + end subroutine psi_i2gthzmm subroutine psi_i2gthzv(n,idx,x,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_i2pk_) :: x(:), y(:) end subroutine psi_i2gthzv @@ -124,7 +134,7 @@ module psi_i2_serial_mod subroutine psi_i2sctv(n,idx,x,beta,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none - + integer(psb_ipk_) :: n, idx(:) integer(psb_i2pk_) :: beta, x(:), y(:) end subroutine psi_i2sctv diff --git a/base/modules/auxil/psi_m_serial_mod.f90 b/base/modules/auxil/psi_m_serial_mod.f90 index e9575fc7b..2acb74829 100644 --- a/base/modules/auxil/psi_m_serial_mod.f90 +++ b/base/modules/auxil/psi_m_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_m_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ @@ -36,7 +36,7 @@ module psi_m_serial_mod ! 2-D version subroutine psb_mgelp(trans,iperm,x,info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_mpk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_m_serial_mod end subroutine psb_mgelp subroutine psb_mgelpv(trans,iperm,x,info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_mpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_mgelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_maxpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n integer(psb_mpk_), intent (in) :: x(:,:) integer(psb_mpk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_m_serial_mod end subroutine psi_maxpby subroutine psi_maxpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m integer(psb_mpk_), intent (in) :: x(:) integer(psb_mpk_), intent (inout) :: y(:) integer(psb_mpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_maxpbyv + subroutine psi_maxpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_mpk_), intent (in) :: x(:) + integer(psb_mpk_), intent (in) :: y(:) + integer(psb_mpk_), intent (in) :: z(:) + integer(psb_mpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_maxpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_m_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) integer(psb_mpk_) :: x(:,:), y(:) - + end subroutine psi_mgthzmv subroutine psi_mgthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) integer(psb_mpk_) :: x(:,:), y(:,:) - + end subroutine psi_mgthzmm subroutine psi_mgthzv(n,idx,x,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_mpk_) :: x(:), y(:) end subroutine psi_mgthzv @@ -124,7 +134,7 @@ module psi_m_serial_mod subroutine psi_msctv(n,idx,x,beta,y) import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none - + integer(psb_ipk_) :: n, idx(:) integer(psb_mpk_) :: beta, x(:), y(:) end subroutine psi_msctv diff --git a/base/modules/auxil/psi_s_serial_mod.f90 b/base/modules/auxil/psi_s_serial_mod.f90 index 443b16fe8..ac3dbb624 100644 --- a/base/modules/auxil/psi_s_serial_mod.f90 +++ b/base/modules/auxil/psi_s_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_s_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_ @@ -36,7 +36,7 @@ module psi_s_serial_mod ! 2-D version subroutine psb_sgelp(trans,iperm,x,info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none real(psb_spk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_s_serial_mod end subroutine psb_sgelp subroutine psb_sgelpv(trans,iperm,x,info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none real(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_sgelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_saxpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n real(psb_spk_), intent (in) :: x(:,:) real(psb_spk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_s_serial_mod end subroutine psi_saxpby subroutine psi_saxpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_spk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent (in) :: x(:) real(psb_spk_), intent (inout) :: y(:) real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_saxpbyv + subroutine psi_saxpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent (in) :: x(:) + real(psb_spk_), intent (in) :: y(:) + real(psb_spk_), intent (in) :: z(:) + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_saxpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_s_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) real(psb_spk_) :: x(:,:), y(:) - + end subroutine psi_sgthzmv subroutine psi_sgthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_spk_ implicit none integer(psb_ipk_) :: n, k, idx(:) real(psb_spk_) :: x(:,:), y(:,:) - + end subroutine psi_sgthzmm subroutine psi_sgthzv(n,idx,x,y) import :: psb_ipk_, psb_spk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: x(:), y(:) end subroutine psi_sgthzv @@ -124,7 +134,7 @@ module psi_s_serial_mod subroutine psi_ssctv(n,idx,x,beta,y) import :: psb_ipk_, psb_spk_ implicit none - + integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:), y(:) end subroutine psi_ssctv diff --git a/base/modules/auxil/psi_z_serial_mod.f90 b/base/modules/auxil/psi_z_serial_mod.f90 index f0d7dd115..ee148ef2c 100644 --- a/base/modules/auxil/psi_z_serial_mod.f90 +++ b/base/modules/auxil/psi_z_serial_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_z_serial_mod use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_dpk_ @@ -36,7 +36,7 @@ module psi_z_serial_mod ! 2-D version subroutine psb_zgelp(trans,iperm,x,info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none complex(psb_dpk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info @@ -44,18 +44,18 @@ module psi_z_serial_mod end subroutine psb_zgelp subroutine psb_zgelpv(trans,iperm,x,info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans end subroutine psb_zgelpv end interface psb_gelp - - interface psb_geaxpby + + interface psb_geaxpby subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n complex(psb_dpk_), intent (in) :: x(:,:) complex(psb_dpk_), intent (inout) :: y(:,:) @@ -64,13 +64,23 @@ module psi_z_serial_mod end subroutine psi_zaxpby subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent (in) :: x(:) complex(psb_dpk_), intent (inout) :: y(:) complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info end subroutine psi_zaxpbyv + subroutine psi_zaxpbyv2(m,alpha, x, beta, y, z, info) + import :: psb_ipk_, psb_dpk_ + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent (in) :: x(:) + complex(psb_dpk_), intent (in) :: y(:) + complex(psb_dpk_), intent (in) :: z(:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zaxpbyv2 end interface psb_geaxpby interface psi_gth @@ -91,18 +101,18 @@ module psi_z_serial_mod implicit none integer(psb_ipk_) :: n, k, idx(:) complex(psb_dpk_) :: x(:,:), y(:) - + end subroutine psi_zgthzmv subroutine psi_zgthzmm(n,k,idx,x,y) import :: psb_ipk_, psb_dpk_ implicit none integer(psb_ipk_) :: n, k, idx(:) complex(psb_dpk_) :: x(:,:), y(:,:) - + end subroutine psi_zgthzmm subroutine psi_zgthzv(n,idx,x,y) import :: psb_ipk_, psb_dpk_ - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: x(:), y(:) end subroutine psi_zgthzv @@ -124,7 +134,7 @@ module psi_z_serial_mod subroutine psi_zsctv(n,idx,x,beta,y) import :: psb_ipk_, psb_dpk_ implicit none - + integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:), y(:) end subroutine psi_zsctv diff --git a/base/modules/penv/psi_collective_mod.F90 b/base/modules/penv/psi_collective_mod.F90 index e382d6927..0fb372410 100644 --- a/base/modules/penv/psi_collective_mod.F90 +++ b/base/modules/penv/psi_collective_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psi_collective_mod use psi_penv_mod use psi_m_collective_mod @@ -42,10 +42,10 @@ module psi_collective_mod module procedure psb_hbcasts, psb_hbcastv,& & psb_hbcasts_ec, psb_hbcastv_ec,& & psb_lbcasts, psb_lbcastv, & - & psb_lbcasts_ec, psb_lbcastv_ec + & psb_lbcasts_ec, psb_lbcastv_ec end interface psb_bcast - + #if defined(SHORT_INTEGERS) interface psb_sum module procedure psb_i2sums, psb_i2sumv, psb_i2summ, & @@ -55,12 +55,12 @@ module psi_collective_mod contains - + subroutine psb_hbcasts(ictxt,dat,root,length) #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -85,7 +85,7 @@ contains call psb_info(ictxt,iam,np) call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info) -#endif +#endif end subroutine psb_hbcasts @@ -93,7 +93,7 @@ contains #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -110,24 +110,24 @@ contains root_ = psb_root_ endif length_ = len(dat) - size_ = size(dat) + size_ = size(dat) call psb_info(ictxt,iam,np) call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info) -#endif +#endif end subroutine psb_hbcastv subroutine psb_hbcasts_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt character(len=*), intent(inout) :: dat integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_bcast(ictxt_,dat,root_) else @@ -136,14 +136,14 @@ contains end subroutine psb_hbcasts_ec subroutine psb_hbcastv_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt character(len=*), intent(inout) :: dat(:) integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_bcast(ictxt_,dat,root_) else @@ -152,12 +152,12 @@ contains end subroutine psb_hbcastv_ec - + subroutine psb_lbcasts(ictxt,dat,root) #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -176,16 +176,41 @@ contains call psb_info(ictxt,iam,np) call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info) -#endif +#endif end subroutine psb_lbcasts + subroutine psb_lallreduceand(ictxt,dat,rec) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(inout) :: dat + logical, intent(inout), optional :: rec + + integer(psb_mpk_) :: iam, np, info + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + if (present(rec)) then + call mpi_allreduce(dat,rec,1,MPI_LOGICAL,MPI_LAND,ictxt,info) + else + call mpi_allreduce(MPI_IN_PLACE,dat,1,MPI_LOGICAL,MPI_LAND,ictxt,info) + endif +#endif + +end subroutine psb_lallreduceand + subroutine psb_lbcastv(ictxt,dat,root) #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -204,20 +229,20 @@ contains call psb_info(ictxt,iam,np) call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info) -#endif +#endif end subroutine psb_lbcastv subroutine psb_lbcasts_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt logical, intent(inout) :: dat integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_bcast(ictxt_,dat,root_) else @@ -226,14 +251,14 @@ contains end subroutine psb_lbcasts_ec subroutine psb_lbcastv_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt logical, intent(inout) :: dat(:) integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_bcast(ictxt_,dat,root_) else @@ -242,14 +267,14 @@ contains end subroutine psb_lbcastv_ec - + #if defined(SHORT_INTEGERS) subroutine psb_i2sums(ictxt,dat,root) #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -265,12 +290,12 @@ contains call psb_info(ictxt,iam,np) - if (present(root)) then + if (present(root)) then root_ = root else root_ = -1 endif - if (root_ == -1) then + if (root_ == -1) then call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,ictxt,info) dat = dat_ else @@ -278,7 +303,7 @@ contains if (iam == root_) dat = dat_ endif -#endif +#endif end subroutine psb_i2sums subroutine psb_i2sumv(ictxt,dat,root) @@ -286,7 +311,7 @@ contains #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -302,18 +327,18 @@ contains call psb_info(ictxt,iam,np) - if (present(root)) then + if (present(root)) then root_ = root else root_ = -1 endif - if (root_ == -1) then + if (root_ == -1) then call psb_realloc(size(dat),dat_,iinfo) dat_=dat if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,ictxt,info) else - if (iam == root_) then + if (iam == root_) then call psb_realloc(size(dat),dat_,iinfo) dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) @@ -321,7 +346,7 @@ contains call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) end if endif -#endif +#endif end subroutine psb_i2sumv subroutine psb_i2summ(ictxt,dat,root) @@ -329,7 +354,7 @@ contains #ifdef MPI_MOD use mpi #endif - implicit none + implicit none #ifdef MPI_H include 'mpif.h' #endif @@ -345,18 +370,18 @@ contains #if !defined(SERIAL_MPI) call psb_info(ictxt,iam,np) - if (present(root)) then + if (present(root)) then root_ = root else root_ = -1 endif - if (root_ == -1) then + if (root_ == -1) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_=dat if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& & psb_mpi_i2pk_,mpi_sum,ictxt,info) else - if (iam == root_) then + if (iam == root_) then call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) dat_=dat call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) @@ -364,18 +389,18 @@ contains call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) end if endif -#endif +#endif end subroutine psb_i2summ subroutine psb_i2sums_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt integer(psb_i2pk_), intent(inout) :: dat integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_sum(ictxt_,dat,root_) else @@ -384,14 +409,14 @@ contains end subroutine psb_i2sums_ec subroutine psb_i2sumv_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt integer(psb_i2pk_), intent(inout) :: dat(:) integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_sum(ictxt_,dat,root_) else @@ -400,14 +425,14 @@ contains end subroutine psb_i2sumv_ec subroutine psb_i2summ_ec(ictxt,dat,root) - implicit none + implicit none integer(psb_epk_), intent(in) :: ictxt integer(psb_i2pk_), intent(inout) :: dat(:,:) integer(psb_epk_), intent(in), optional :: root integer(psb_mpk_) :: ictxt_, root_ ictxt_ = ictxt - if (present(root)) then + if (present(root)) then root_ = root call psb_sum(ictxt_,dat,root_) else diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index 53271ea90..b4f1fe283 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,10 +27,10 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_c_psblas_mod - use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_ + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_ use psb_c_vect_mod, only : psb_c_vect_type use psb_c_mat_mod, only : psb_cspmat_type @@ -44,7 +44,7 @@ module psb_c_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_cdot_vect - function psb_cdotv(x, y, desc_a,info,global) + function psb_cdotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_) :: psb_cdotv @@ -53,7 +53,7 @@ module psb_c_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_cdotv - function psb_cdot(x, y, desc_a, info, jx, jy,global) + function psb_cdot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type complex(psb_spk_) :: psb_cdot @@ -69,7 +69,7 @@ module psb_c_psblas_mod interface psb_gedots subroutine psb_cdotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & - & psb_c_vect_type, psb_cspmat_type + & psb_c_vect_type, psb_cspmat_type complex(psb_spk_), intent(out) :: res complex(psb_spk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a @@ -78,7 +78,7 @@ module psb_c_psblas_mod end subroutine psb_cdotvs subroutine psb_cmdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & - & psb_c_vect_type, psb_cspmat_type + & psb_c_vect_type, psb_cspmat_type complex(psb_spk_), intent(out) :: res(:) complex(psb_spk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -98,6 +98,17 @@ module psb_c_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_caxpby_vect + subroutine psb_caxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_c_vect_type, psb_cspmat_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_caxpby_vect_out subroutine psb_caxpbyv(alpha, x, beta, y,& & desc_a, info) import :: psb_desc_type, psb_spk_, psb_ipk_, & @@ -108,6 +119,17 @@ module psb_c_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_caxpbyv + subroutine psb_caxpbyvout(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_c_vect_type, psb_cspmat_type + complex(psb_spk_), intent (in) :: x(:) + complex(psb_spk_), intent (in) :: y(:) + complex(psb_spk_), intent (inout) :: z(:) + complex(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_caxpbyvout subroutine psb_caxpby(alpha, x, beta, y,& & desc_a, info, n, jx, jy) import :: psb_desc_type, psb_spk_, psb_ipk_, & @@ -155,10 +177,10 @@ module psb_c_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrmi procedure psb_camax, psb_camaxv, psb_camax_vect - end interface + end interface interface psb_normi procedure psb_camax, psb_camaxv, psb_camax_vect - end interface + end interface #endif interface psb_geamaxs @@ -183,6 +205,7 @@ module psb_c_psblas_mod end subroutine psb_cmamaxs end interface + interface psb_geasum function psb_casum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & @@ -238,10 +261,10 @@ module psb_c_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrm1 procedure psb_casum, psb_casumv, psb_casum_vect - end interface + end interface interface psb_norm1 procedure psb_casum, psb_casumv, psb_casum_vect - end interface + end interface #endif interface psb_genrm2 @@ -273,12 +296,33 @@ module psb_c_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_cnrm2_vect + function psb_cnrm2_weight_vect(x,w, desc_a, info,global) result(res) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_c_vect_type, psb_cspmat_type + real(psb_spk_) :: res + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: w + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_cnrm2_weight_vect + function psb_cnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_c_vect_type, psb_cspmat_type + real(psb_spk_) :: res + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: w + type(psb_c_vect_type), intent (inout) :: idv + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_cnrm2_weightmask_vect end interface #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm2 - procedure psb_cnrm2, psb_cnrm2v, psb_cnrm2_vect - end interface + procedure psb_cnrm2, psb_cnrm2v, psb_cnrm2_vect, psb_cnrm2_weight_vect, psb_cnrm2_weightmask_vect + end interface #endif interface psb_genrm2s @@ -309,7 +353,7 @@ module psb_c_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_normi procedure psb_cnrmi - end interface + end interface #endif interface psb_spnrm1 @@ -323,11 +367,11 @@ module psb_c_psblas_mod logical, intent(in), optional :: global end function psb_cspnrm1 end interface - + #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm1 procedure psb_cspnrm1 - end interface + end interface #endif interface psb_spmm @@ -378,7 +422,7 @@ module psb_c_psblas_mod interface psb_spsm subroutine psb_cspsm(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, n, jx, jy, work) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type @@ -395,7 +439,7 @@ module psb_c_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_cspsm subroutine psb_cspsv(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type @@ -411,7 +455,7 @@ module psb_c_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_cspsv subroutine psb_cspsv_vect(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_c_vect_type, psb_cspmat_type @@ -428,4 +472,184 @@ module psb_c_psblas_mod end subroutine psb_cspsv_vect end interface + interface psb_gemlt + subroutine psb_cmlt_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cmlt_vect + subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type, psb_spk_ + complex(psb_spk_), intent(in) :: alpha,beta + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_cmlt_vect2 + end interface + + interface psb_gediv + subroutine psb_cdiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cdiv_vect + subroutine psb_cdiv_vect2(x,y,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cdiv_vect2 + subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_cdiv_vect_check + subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_cdiv_vect2_check + end interface + + interface psb_geinv + subroutine psb_cinv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cinv_vect + subroutine psb_cinv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_cinv_vect_check + end interface + + interface psb_geabs + subroutine psb_cabs_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cabs_vect + end interface + + interface psb_gecmp + subroutine psb_ccmp_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type, psb_spk_ + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ccmp_vect + subroutine psb_ccmp_spmatval(a,val,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_cspmat_type, psb_spk_ + type(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_ccmp_spmatval + subroutine psb_ccmp_spmat(a,b,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_cspmat_type, psb_spk_ + type(psb_cspmat_type), intent(inout) :: a + type(psb_cspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_ccmp_spmat + end interface + interface psb_geaddconst + subroutine psb_caddconst_vect(x,b,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type, psb_spk_ + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_caddconst_vect + end interface + + + interface psb_nnz + function psb_cget_nnz(a,desc_a,info) result(res) + import :: psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_cspmat_type, psb_spk_ + integer(psb_lpk_) :: res + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matupd + function psb_c_is_matupd(a,desc_a,info) result(res) + import :: psb_desc_type, psb_cspmat_type, & + & psb_spk_, psb_ipk_ + logical :: res + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matasb + function psb_c_is_matasb(a,desc_a,info) result(res) + import :: psb_desc_type, psb_cspmat_type, & + & psb_spk_, psb_ipk_ + logical :: res + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matbld + function psb_c_is_matbld(a,desc_a,info) result(res) + import :: psb_desc_type, psb_cspmat_type, & + & psb_spk_, psb_ipk_ + logical :: res + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + end module psb_c_psblas_mod diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index 56386f92d..a77481169 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,10 +27,10 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_d_psblas_mod - use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_ use psb_d_vect_mod, only : psb_d_vect_type use psb_d_mat_mod, only : psb_dspmat_type @@ -44,7 +44,7 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_ddot_vect - function psb_ddotv(x, y, desc_a,info,global) + function psb_ddotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: psb_ddotv @@ -53,7 +53,7 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_ddotv - function psb_ddot(x, y, desc_a, info, jx, jy,global) + function psb_ddot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type real(psb_dpk_) :: psb_ddot @@ -69,7 +69,7 @@ module psb_d_psblas_mod interface psb_gedots subroutine psb_ddotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & - & psb_d_vect_type, psb_dspmat_type + & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent(out) :: res real(psb_dpk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a @@ -78,7 +78,7 @@ module psb_d_psblas_mod end subroutine psb_ddotvs subroutine psb_dmdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & - & psb_d_vect_type, psb_dspmat_type + & psb_d_vect_type, psb_dspmat_type real(psb_dpk_), intent(out) :: res(:) real(psb_dpk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -98,6 +98,17 @@ module psb_d_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_daxpby_vect + subroutine psb_daxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_d_vect_type, psb_dspmat_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_daxpby_vect_out subroutine psb_daxpbyv(alpha, x, beta, y,& & desc_a, info) import :: psb_desc_type, psb_dpk_, psb_ipk_, & @@ -108,6 +119,17 @@ module psb_d_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_daxpbyv + subroutine psb_daxpbyvout(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_d_vect_type, psb_dspmat_type + real(psb_dpk_), intent (in) :: x(:) + real(psb_dpk_), intent (in) :: y(:) + real(psb_dpk_), intent (inout) :: z(:) + real(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_daxpbyvout subroutine psb_daxpby(alpha, x, beta, y,& & desc_a, info, n, jx, jy) import :: psb_desc_type, psb_dpk_, psb_ipk_, & @@ -155,10 +177,10 @@ module psb_d_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrmi procedure psb_damax, psb_damaxv, psb_damax_vect - end interface + end interface interface psb_normi procedure psb_damax, psb_damaxv, psb_damax_vect - end interface + end interface #endif interface psb_geamaxs @@ -183,6 +205,18 @@ module psb_d_psblas_mod end subroutine psb_dmamaxs end interface + interface psb_gemin + function psb_dmin_vect(x, desc_a, info,global) result(res) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_d_vect_type, psb_dspmat_type + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_dmin_vect + end interface + interface psb_geasum function psb_dasum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & @@ -238,10 +272,10 @@ module psb_d_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrm1 procedure psb_dasum, psb_dasumv, psb_dasum_vect - end interface + end interface interface psb_norm1 procedure psb_dasum, psb_dasumv, psb_dasum_vect - end interface + end interface #endif interface psb_genrm2 @@ -273,12 +307,33 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_dnrm2_vect + function psb_dnrm2_weight_vect(x,w, desc_a, info,global) result(res) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_d_vect_type, psb_dspmat_type + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: w + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_dnrm2_weight_vect + function psb_dnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_d_vect_type, psb_dspmat_type + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: w + type(psb_d_vect_type), intent (inout) :: idv + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_dnrm2_weightmask_vect end interface #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm2 - procedure psb_dnrm2, psb_dnrm2v, psb_dnrm2_vect - end interface + procedure psb_dnrm2, psb_dnrm2v, psb_dnrm2_vect, psb_dnrm2_weight_vect, psb_dnrm2_weightmask_vect + end interface #endif interface psb_genrm2s @@ -309,7 +364,7 @@ module psb_d_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_normi procedure psb_dnrmi - end interface + end interface #endif interface psb_spnrm1 @@ -323,11 +378,11 @@ module psb_d_psblas_mod logical, intent(in), optional :: global end function psb_dspnrm1 end interface - + #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm1 procedure psb_dspnrm1 - end interface + end interface #endif interface psb_spmm @@ -378,7 +433,7 @@ module psb_d_psblas_mod interface psb_spsm subroutine psb_dspsm(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, n, jx, jy, work) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type @@ -395,7 +450,7 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_dspsm subroutine psb_dspsv(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type @@ -411,7 +466,7 @@ module psb_d_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_dspsv subroutine psb_dspsv_vect(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_d_vect_type, psb_dspmat_type @@ -428,4 +483,208 @@ module psb_d_psblas_mod end subroutine psb_dspsv_vect end interface + interface psb_gemlt + subroutine psb_dmlt_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dmlt_vect + subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_dmlt_vect2 + end interface + + interface psb_gediv + subroutine psb_ddiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ddiv_vect + subroutine psb_ddiv_vect2(x,y,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ddiv_vect2 + subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_ddiv_vect_check + subroutine psb_ddiv_vect2_check(x,y,z,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_ddiv_vect2_check + end interface + + interface psb_geinv + subroutine psb_dinv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dinv_vect + subroutine psb_dinv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_dinv_vect_check + end interface + + interface psb_geabs + subroutine psb_dabs_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dabs_vect + end interface + + interface psb_gecmp + subroutine psb_dcmp_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dcmp_vect + subroutine psb_dcmp_spmatval(a,val,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_dspmat_type, psb_dpk_ + type(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_dcmp_spmatval + subroutine psb_dcmp_spmat(a,b,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_dspmat_type, psb_dpk_ + type(psb_dspmat_type), intent(inout) :: a + type(psb_dspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_dcmp_spmat + end interface + interface psb_geaddconst + subroutine psb_daddconst_vect(x,b,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_daddconst_vect + end interface + + interface psb_mask + subroutine psb_dmask_vect(c,x,m,t,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + type(psb_d_vect_type), intent (inout) :: c + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: m + logical, intent(out) :: t + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dmask_vect + end interface + interface psb_minquotient + function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function + end interface + + interface psb_nnz + function psb_dget_nnz(a,desc_a,info) result(res) + import :: psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_dspmat_type, psb_dpk_ + integer(psb_lpk_) :: res + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matupd + function psb_d_is_matupd(a,desc_a,info) result(res) + import :: psb_desc_type, psb_dspmat_type, & + & psb_dpk_, psb_ipk_ + logical :: res + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matasb + function psb_d_is_matasb(a,desc_a,info) result(res) + import :: psb_desc_type, psb_dspmat_type, & + & psb_dpk_, psb_ipk_ + logical :: res + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matbld + function psb_d_is_matbld(a,desc_a,info) result(res) + import :: psb_desc_type, psb_dspmat_type, & + & psb_dpk_, psb_ipk_ + logical :: res + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + end module psb_d_psblas_mod diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index a764bb402..803c7328a 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,10 +27,10 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_s_psblas_mod - use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_ + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_ use psb_s_vect_mod, only : psb_s_vect_type use psb_s_mat_mod, only : psb_sspmat_type @@ -44,7 +44,7 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_sdot_vect - function psb_sdotv(x, y, desc_a,info,global) + function psb_sdotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: psb_sdotv @@ -53,7 +53,7 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_sdotv - function psb_sdot(x, y, desc_a, info, jx, jy,global) + function psb_sdot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type real(psb_spk_) :: psb_sdot @@ -69,7 +69,7 @@ module psb_s_psblas_mod interface psb_gedots subroutine psb_sdotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & - & psb_s_vect_type, psb_sspmat_type + & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent(out) :: res real(psb_spk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a @@ -78,7 +78,7 @@ module psb_s_psblas_mod end subroutine psb_sdotvs subroutine psb_smdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_spk_, psb_ipk_, & - & psb_s_vect_type, psb_sspmat_type + & psb_s_vect_type, psb_sspmat_type real(psb_spk_), intent(out) :: res(:) real(psb_spk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -98,6 +98,17 @@ module psb_s_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_saxpby_vect + subroutine psb_saxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_s_vect_type, psb_sspmat_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_saxpby_vect_out subroutine psb_saxpbyv(alpha, x, beta, y,& & desc_a, info) import :: psb_desc_type, psb_spk_, psb_ipk_, & @@ -108,6 +119,17 @@ module psb_s_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_saxpbyv + subroutine psb_saxpbyvout(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_s_vect_type, psb_sspmat_type + real(psb_spk_), intent (in) :: x(:) + real(psb_spk_), intent (in) :: y(:) + real(psb_spk_), intent (inout) :: z(:) + real(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_saxpbyvout subroutine psb_saxpby(alpha, x, beta, y,& & desc_a, info, n, jx, jy) import :: psb_desc_type, psb_spk_, psb_ipk_, & @@ -155,10 +177,10 @@ module psb_s_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrmi procedure psb_samax, psb_samaxv, psb_samax_vect - end interface + end interface interface psb_normi procedure psb_samax, psb_samaxv, psb_samax_vect - end interface + end interface #endif interface psb_geamaxs @@ -183,6 +205,18 @@ module psb_s_psblas_mod end subroutine psb_smamaxs end interface + interface psb_gemin + function psb_smin_vect(x, desc_a, info,global) result(res) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_s_vect_type, psb_sspmat_type + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_smin_vect + end interface + interface psb_geasum function psb_sasum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_spk_, psb_ipk_, & @@ -238,10 +272,10 @@ module psb_s_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrm1 procedure psb_sasum, psb_sasumv, psb_sasum_vect - end interface + end interface interface psb_norm1 procedure psb_sasum, psb_sasumv, psb_sasum_vect - end interface + end interface #endif interface psb_genrm2 @@ -273,12 +307,33 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_snrm2_vect + function psb_snrm2_weight_vect(x,w, desc_a, info,global) result(res) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_s_vect_type, psb_sspmat_type + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: w + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_snrm2_weight_vect + function psb_snrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + import :: psb_desc_type, psb_spk_, psb_ipk_, & + & psb_s_vect_type, psb_sspmat_type + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: w + type(psb_s_vect_type), intent (inout) :: idv + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_snrm2_weightmask_vect end interface #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm2 - procedure psb_snrm2, psb_snrm2v, psb_snrm2_vect - end interface + procedure psb_snrm2, psb_snrm2v, psb_snrm2_vect, psb_snrm2_weight_vect, psb_snrm2_weightmask_vect + end interface #endif interface psb_genrm2s @@ -309,7 +364,7 @@ module psb_s_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_normi procedure psb_snrmi - end interface + end interface #endif interface psb_spnrm1 @@ -323,11 +378,11 @@ module psb_s_psblas_mod logical, intent(in), optional :: global end function psb_sspnrm1 end interface - + #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm1 procedure psb_sspnrm1 - end interface + end interface #endif interface psb_spmm @@ -378,7 +433,7 @@ module psb_s_psblas_mod interface psb_spsm subroutine psb_sspsm(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, n, jx, jy, work) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type @@ -395,7 +450,7 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_sspsm subroutine psb_sspsv(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type @@ -411,7 +466,7 @@ module psb_s_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_sspsv subroutine psb_sspsv_vect(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_spk_, psb_ipk_, & & psb_s_vect_type, psb_sspmat_type @@ -428,4 +483,208 @@ module psb_s_psblas_mod end subroutine psb_sspsv_vect end interface + interface psb_gemlt + subroutine psb_smlt_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_smlt_vect + subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_smlt_vect2 + end interface + + interface psb_gediv + subroutine psb_sdiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sdiv_vect + subroutine psb_sdiv_vect2(x,y,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sdiv_vect2 + subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_sdiv_vect_check + subroutine psb_sdiv_vect2_check(x,y,z,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_sdiv_vect2_check + end interface + + interface psb_geinv + subroutine psb_sinv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sinv_vect + subroutine psb_sinv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_sinv_vect_check + end interface + + interface psb_geabs + subroutine psb_sabs_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sabs_vect + end interface + + interface psb_gecmp + subroutine psb_scmp_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_scmp_vect + subroutine psb_scmp_spmatval(a,val,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_sspmat_type, psb_spk_ + type(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_scmp_spmatval + subroutine psb_scmp_spmat(a,b,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_sspmat_type, psb_spk_ + type(psb_sspmat_type), intent(inout) :: a + type(psb_sspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_scmp_spmat + end interface + interface psb_geaddconst + subroutine psb_saddconst_vect(x,b,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_saddconst_vect + end interface + + interface psb_mask + subroutine psb_smask_vect(c,x,m,t,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + type(psb_s_vect_type), intent (inout) :: c + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: m + logical, intent(out) :: t + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_smask_vect + end interface + interface psb_minquotient + function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function + end interface + + interface psb_nnz + function psb_sget_nnz(a,desc_a,info) result(res) + import :: psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_sspmat_type, psb_spk_ + integer(psb_lpk_) :: res + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matupd + function psb_s_is_matupd(a,desc_a,info) result(res) + import :: psb_desc_type, psb_sspmat_type, & + & psb_spk_, psb_ipk_ + logical :: res + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matasb + function psb_s_is_matasb(a,desc_a,info) result(res) + import :: psb_desc_type, psb_sspmat_type, & + & psb_spk_, psb_ipk_ + logical :: res + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matbld + function psb_s_is_matbld(a,desc_a,info) result(res) + import :: psb_desc_type, psb_sspmat_type, & + & psb_spk_, psb_ipk_ + logical :: res + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + end module psb_s_psblas_mod diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index 08ee92a72..60a373e46 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,10 +27,10 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_z_psblas_mod - use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_ use psb_z_vect_mod, only : psb_z_vect_type use psb_z_mat_mod, only : psb_zspmat_type @@ -44,7 +44,7 @@ module psb_z_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_zdot_vect - function psb_zdotv(x, y, desc_a,info,global) + function psb_zdotv(x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_) :: psb_zdotv @@ -53,7 +53,7 @@ module psb_z_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_zdotv - function psb_zdot(x, y, desc_a, info, jx, jy,global) + function psb_zdot(x, y, desc_a, info, jx, jy,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_) :: psb_zdot @@ -69,7 +69,7 @@ module psb_z_psblas_mod interface psb_gedots subroutine psb_zdotvs(res,x, y, desc_a, info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & - & psb_z_vect_type, psb_zspmat_type + & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_), intent(out) :: res complex(psb_dpk_), intent(in) :: x(:), y(:) type(psb_desc_type), intent(in) :: desc_a @@ -78,7 +78,7 @@ module psb_z_psblas_mod end subroutine psb_zdotvs subroutine psb_zmdots(res,x, y, desc_a,info,global) import :: psb_desc_type, psb_dpk_, psb_ipk_, & - & psb_z_vect_type, psb_zspmat_type + & psb_z_vect_type, psb_zspmat_type complex(psb_dpk_), intent(out) :: res(:) complex(psb_dpk_), intent(in) :: x(:,:), y(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -98,6 +98,17 @@ module psb_z_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_zaxpby_vect + subroutine psb_zaxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_z_vect_type, psb_zspmat_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zaxpby_vect_out subroutine psb_zaxpbyv(alpha, x, beta, y,& & desc_a, info) import :: psb_desc_type, psb_dpk_, psb_ipk_, & @@ -108,6 +119,17 @@ module psb_z_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_zaxpbyv + subroutine psb_zaxpbyvout(alpha, x, beta, y,& + & z, desc_a, info) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_z_vect_type, psb_zspmat_type + complex(psb_dpk_), intent (in) :: x(:) + complex(psb_dpk_), intent (in) :: y(:) + complex(psb_dpk_), intent (inout) :: z(:) + complex(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zaxpbyvout subroutine psb_zaxpby(alpha, x, beta, y,& & desc_a, info, n, jx, jy) import :: psb_desc_type, psb_dpk_, psb_ipk_, & @@ -155,10 +177,10 @@ module psb_z_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrmi procedure psb_zamax, psb_zamaxv, psb_zamax_vect - end interface + end interface interface psb_normi procedure psb_zamax, psb_zamaxv, psb_zamax_vect - end interface + end interface #endif interface psb_geamaxs @@ -183,6 +205,7 @@ module psb_z_psblas_mod end subroutine psb_zmamaxs end interface + interface psb_geasum function psb_zasum_vect(x, desc_a, info,global) result(res) import :: psb_desc_type, psb_dpk_, psb_ipk_, & @@ -238,10 +261,10 @@ module psb_z_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_genrm1 procedure psb_zasum, psb_zasumv, psb_zasum_vect - end interface + end interface interface psb_norm1 procedure psb_zasum, psb_zasumv, psb_zasum_vect - end interface + end interface #endif interface psb_genrm2 @@ -273,12 +296,33 @@ module psb_z_psblas_mod integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: global end function psb_znrm2_vect + function psb_znrm2_weight_vect(x,w, desc_a, info,global) result(res) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_z_vect_type, psb_zspmat_type + real(psb_dpk_) :: res + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: w + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_znrm2_weight_vect + function psb_znrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + import :: psb_desc_type, psb_dpk_, psb_ipk_, & + & psb_z_vect_type, psb_zspmat_type + real(psb_dpk_) :: res + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: w + type(psb_z_vect_type), intent (inout) :: idv + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + end function psb_znrm2_weightmask_vect end interface #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm2 - procedure psb_znrm2, psb_znrm2v, psb_znrm2_vect - end interface + procedure psb_znrm2, psb_znrm2v, psb_znrm2_vect, psb_znrm2_weight_vect, psb_znrm2_weightmask_vect + end interface #endif interface psb_genrm2s @@ -309,7 +353,7 @@ module psb_z_psblas_mod #if ! defined(HAVE_BUGGY_GENERICS) interface psb_normi procedure psb_znrmi - end interface + end interface #endif interface psb_spnrm1 @@ -323,11 +367,11 @@ module psb_z_psblas_mod logical, intent(in), optional :: global end function psb_zspnrm1 end interface - + #if ! defined(HAVE_BUGGY_GENERICS) interface psb_norm1 procedure psb_zspnrm1 - end interface + end interface #endif interface psb_spmm @@ -378,7 +422,7 @@ module psb_z_psblas_mod interface psb_spsm subroutine psb_zspsm(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, n, jx, jy, work) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type @@ -395,7 +439,7 @@ module psb_z_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_zspsm subroutine psb_zspsv(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type @@ -411,7 +455,7 @@ module psb_z_psblas_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_zspsv subroutine psb_zspsv_vect(alpha, t, x, beta, y,& - & desc_a, info, trans, scale, choice,& + & desc_a, info, trans, scale, choice,& & diag, work) import :: psb_desc_type, psb_dpk_, psb_ipk_, & & psb_z_vect_type, psb_zspmat_type @@ -428,4 +472,184 @@ module psb_z_psblas_mod end subroutine psb_zspsv_vect end interface + interface psb_gemlt + subroutine psb_zmlt_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zmlt_vect + subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type, psb_dpk_ + complex(psb_dpk_), intent(in) :: alpha,beta + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_zmlt_vect2 + end interface + + interface psb_gediv + subroutine psb_zdiv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zdiv_vect + subroutine psb_zdiv_vect2(x,y,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zdiv_vect2 + subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_zdiv_vect_check + subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_zdiv_vect2_check + end interface + + interface psb_geinv + subroutine psb_zinv_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zinv_vect + subroutine psb_zinv_vect_check(x,y,desc_a,info,flag) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + end subroutine psb_zinv_vect_check + end interface + + interface psb_geabs + subroutine psb_zabs_vect(x,y,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zabs_vect + end interface + + interface psb_gecmp + subroutine psb_zcmp_vect(x,c,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type, psb_dpk_ + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zcmp_vect + subroutine psb_zcmp_spmatval(a,val,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_zspmat_type, psb_dpk_ + type(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_zcmp_spmatval + subroutine psb_zcmp_spmat(a,b,tol,desc_a,res,info) + import :: psb_desc_type, psb_ipk_, & + & psb_lpk_, psb_zspmat_type, psb_dpk_ + type(psb_zspmat_type), intent(inout) :: a + type(psb_zspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + end subroutine psb_zcmp_spmat + end interface + interface psb_geaddconst + subroutine psb_zaddconst_vect(x,b,z,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type, psb_dpk_ + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zaddconst_vect + end interface + + + interface psb_nnz + function psb_zget_nnz(a,desc_a,info) result(res) + import :: psb_desc_type, psb_ipk_, psb_lpk_, & + & psb_zspmat_type, psb_dpk_ + integer(psb_lpk_) :: res + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matupd + function psb_z_is_matupd(a,desc_a,info) result(res) + import :: psb_desc_type, psb_zspmat_type, & + & psb_dpk_, psb_ipk_ + logical :: res + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matasb + function psb_z_is_matasb(a,desc_a,info) result(res) + import :: psb_desc_type, psb_zspmat_type, & + & psb_dpk_, psb_ipk_ + logical :: res + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + + interface psb_is_matbld + function psb_z_is_matbld(a,desc_a,info) result(res) + import :: psb_desc_type, psb_zspmat_type, & + & psb_dpk_, psb_ipk_ + logical :: res + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end function + end interface + end module psb_z_psblas_mod diff --git a/base/modules/serial/psb_base_mat_mod.F90 b/base/modules/serial/psb_base_mat_mod.F90 index b108e9aec..9180142ac 100644 --- a/base/modules/serial/psb_base_mat_mod.F90 +++ b/base/modules/serial/psb_base_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_base_mat_mod ! @@ -64,15 +64,15 @@ ! of the indices, which are PSB_LPK_ so that the entries ! are guaranteed to be able to contain global indices. ! This type only supports data handling and preprocessing, it is -! not supposed to be used for computations. +! not supposed to be used for computations. ! ! module psb_base_mat_mod - - use psb_const_mod + + use psb_const_mod use psi_serial_mod - + ! !> \namespace psb_base_mod \class psb_base_sparse_mat !! The basic data about your matrix. @@ -81,7 +81,7 @@ module psb_base_mat_mod !! storage formats. The grandchild classes are then !! encapsulated to implement the STATE design pattern. !! We have an ambiguity in that the inner class has a - !! "state" variable; we hope the context will make it clear. + !! "state" variable; we hope the context will make it clear. !! !! !! The methods associated to this class can be grouped into three sets: @@ -106,7 +106,7 @@ module psb_base_mat_mod !> Row size integer(psb_ipk_), private :: m !> Col size - integer(psb_ipk_), private :: n + integer(psb_ipk_), private :: n !> Matrix state: !! null: pristine; !! build: it's being filled with entries; @@ -114,17 +114,17 @@ module psb_base_mat_mod !! update: accepts coefficients but only !! in already existing entries. !! The transitions among the states are detailed in - !! psb_T_mat_mod. + !! psb_T_mat_mod. integer(psb_ipk_), private :: state !> How to treat duplicate elements when - !! transitioning from the BUILD to the ASSEMBLED state. + !! transitioning from the BUILD to the ASSEMBLED state. !! While many formats would allow for duplicate !! entries, it is much better to constrain the matrices !! NOT to have duplicate entries, except while in the !! BUILD state; in our overall design, only COO matrices !! can ever be in the BUILD state, hence all other formats !! cannot have duplicate entries. - integer(psb_ipk_), private :: duplicate + integer(psb_ipk_), private :: duplicate !> Is the matrix symmetric? (must also be square) logical, private :: symmetric !> Is the matrix triangular? (must also be square) @@ -137,11 +137,11 @@ module psb_base_mat_mod logical, private :: sorted logical, private :: repeatable_updates=.false. - contains + contains ! == = ================================= ! - ! Getters + ! Getters ! ! ! == = ================================= @@ -168,10 +168,10 @@ module psb_base_mat_mod procedure, pass(a) :: is_by_rows => psb_base_is_by_rows procedure, pass(a) :: is_by_cols => psb_base_is_by_cols procedure, pass(a) :: is_repeatable_updates => psb_base_is_repeatable_updates - + ! == = ================================= ! - ! Setters + ! Setters ! ! == = ================================= procedure, pass(a) :: set_nrows => psb_base_set_nrows @@ -196,7 +196,7 @@ module psb_base_mat_mod ! ! Data management ! - ! == = ================================= + ! == = ================================= procedure, pass(a) :: get_neigh => psb_base_get_neigh procedure, pass(a) :: free => psb_base_free procedure, pass(a) :: asb => psb_base_mat_asb @@ -224,7 +224,7 @@ module psb_base_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => psb_base_mat_sync procedure, pass(a) :: is_host => psb_base_mat_is_host @@ -233,7 +233,7 @@ module psb_base_mat_mod procedure, pass(a) :: set_host => psb_base_mat_set_host procedure, pass(a) :: set_dev => psb_base_mat_set_dev procedure, pass(a) :: set_sync => psb_base_mat_set_sync - + end type psb_base_sparse_mat !> Function: psb_base_get_nz_row @@ -242,7 +242,7 @@ module psb_base_mat_mod !! count(A(idx,:)/=0) !! \param idx The line we are interested in. ! - interface + interface function psb_base_get_nz_row(idx,a) result(res) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: idx @@ -250,14 +250,14 @@ module psb_base_mat_mod integer(psb_ipk_) :: res end function psb_base_get_nz_row end interface - + ! !> Function: psb_base_get_nzeros !! \memberof psb_base_sparse_mat - !! Interface for the get_nzeros method. Equivalent to: - !! count(A(:,:)/=0) + !! Interface for the get_nzeros method. Equivalent to: + !! count(A(:,:)/=0) ! - interface + interface function psb_base_get_nzeros(a) result(res) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(in) :: a @@ -270,9 +270,9 @@ module psb_base_mat_mod !! how many items can A hold with !! its current space allocation? !! (as opposed to how many are - !! currently occupied) - ! - interface + !! currently occupied) + ! + interface function psb_base_get_size(a) result(res) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(in) :: a @@ -284,31 +284,31 @@ module psb_base_mat_mod !> Function reinit: transition state from ASB to UPDATE !! \memberof psb_base_sparse_mat !! \param clear [true] explicitly zero out coefficients. - ! - interface + ! + interface subroutine psb_base_reinit(a,clear) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat - class(psb_base_sparse_mat), intent(inout) :: a + class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_base_reinit end interface - + ! !> Function !! \memberof psb_base_sparse_mat - !! print on file in Matrix Market format. + !! print on file in Matrix Market format. !! \param iout the output unit !! \param iv(:) [none] renumber both row and column indices !! \param head [none] a descriptive header for the matrix data !! \param ivr(:) [none] renumbering for the rows !! \param ivc(:) [none] renumbering for the cols - ! - interface + ! + interface subroutine psb_base_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat, psb_lpk_ integer(psb_ipk_), intent(in) :: iout - class(psb_base_sparse_mat), intent(in) :: a + class(psb_base_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -325,25 +325,25 @@ module psb_base_mat_mod !! Return a list of NZ pairs !! (IA(i),JA(i)) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - ! + ! - interface + interface subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat @@ -358,7 +358,7 @@ module psb_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_base_csgetptn end interface - + ! !> Function get_neigh: !! \memberof psb_base_sparse_mat @@ -372,21 +372,21 @@ module psb_base_mat_mod !! \param n the number of indices returned !! \param info return code !! \param lev [1] find neighbours recursively for LEV levels, - !! i.e. when lev=2 find neighours of neighbours, etc. - ! - interface + !! i.e. when lev=2 find neighours of neighbours, etc. + ! + interface subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat - class(psb_base_sparse_mat), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + class(psb_base_sparse_mat), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev end subroutine psb_base_get_neigh end interface - - ! + + ! ! !> Function allocate_mnnz !! \memberof psb_base_sparse_mat @@ -396,8 +396,8 @@ module psb_base_mat_mod !! \param n number of cols !! \param nz [estimated internally] number of nonzeros to allocate for ! - interface - subroutine psb_base_allocate_mnnz(m,n,a,nz) + interface + subroutine psb_base_allocate_mnnz(m,n,a,nz) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: m,n class(psb_base_sparse_mat), intent(inout) :: a @@ -405,8 +405,8 @@ module psb_base_mat_mod end subroutine psb_base_allocate_mnnz end interface - - ! + + ! ! !> Function reallocate_nz !! \memberof psb_base_sparse_mat @@ -414,40 +414,40 @@ module psb_base_mat_mod !! !! \param nz number of nonzeros to allocate for ! - interface - subroutine psb_base_reallocate_nz(nz,a) + interface + subroutine psb_base_reallocate_nz(nz,a) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: nz class(psb_base_sparse_mat), intent(inout) :: a end subroutine psb_base_reallocate_nz end interface - ! + ! !> Function free !! \memberof psb_base_sparse_mat !! \brief destructor ! - interface - subroutine psb_base_free(a) + interface + subroutine psb_base_free(a) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(inout) :: a end subroutine psb_base_free end interface - - ! - !> Function trim + + ! + !> Function trim !! \memberof psb_base_sparse_mat !! \brief Memory trim !! Make sure the memory allocation of the sparse matrix is as tight as - !! possible given the actual number of nonzeros it contains. + !! possible given the actual number of nonzeros it contains. ! - interface - subroutine psb_base_trim(a) + interface + subroutine psb_base_trim(a) import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(inout) :: a end subroutine psb_base_trim end interface - + ! !> \namespace psb_lbase_mod \class psb_lbase_sparse_mat !! The basic data about your matrix. @@ -456,7 +456,7 @@ module psb_base_mat_mod !! storage formats. The grandchild classes are then !! encapsulated to implement the STATE design pattern. !! We have an ambiguity in that the inner class has a - !! "state" variable; we hope the context will make it clear. + !! "state" variable; we hope the context will make it clear. !! !! !! The methods associated to this class can be grouped into three sets: @@ -481,7 +481,7 @@ module psb_base_mat_mod !> Row size integer(psb_lpk_), private :: m !> Col size - integer(psb_lpk_), private :: n + integer(psb_lpk_), private :: n !> Matrix state: !! null: pristine; !! build: it's being filled with entries; @@ -489,17 +489,17 @@ module psb_base_mat_mod !! update: accepts coefficients but only !! in already existing entries. !! The transitions among the states are detailed in - !! psb_T_mat_mod. + !! psb_T_mat_mod. integer(psb_ipk_), private :: state !> How to treat duplicate elements when - !! transitioning from the BUILD to the ASSEMBLED state. + !! transitioning from the BUILD to the ASSEMBLED state. !! While many formats would allow for duplicate !! entries, it is much better to constrain the matrices !! NOT to have duplicate entries, except while in the !! BUILD state; in our overall design, only COO matrices !! can ever be in the BUILD state, hence all other formats !! cannot have duplicate entries. - integer(psb_ipk_), private :: duplicate + integer(psb_ipk_), private :: duplicate !> Is the matrix symmetric? (must also be square) logical, private :: symmetric !> Is the matrix triangular? (must also be square) @@ -512,11 +512,11 @@ module psb_base_mat_mod logical, private :: sorted logical, private :: repeatable_updates=.false. - contains + contains ! == = ================================= ! - ! Getters + ! Getters ! ! ! == = ================================= @@ -543,15 +543,15 @@ module psb_base_mat_mod procedure, pass(a) :: is_by_rows => psb_lbase_is_by_rows procedure, pass(a) :: is_by_cols => psb_lbase_is_by_cols procedure, pass(a) :: is_repeatable_updates => psb_lbase_is_repeatable_updates - + ! == = ================================= ! - ! Setters + ! Setters ! ! == = ================================= procedure, pass(a) :: set_lnrows => psb_lbase_set_lnrows procedure, pass(a) :: set_lncols => psb_lbase_set_lncols -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) procedure, pass(a) :: set_inrows => psb_lbase_set_inrows procedure, pass(a) :: set_incols => psb_lbase_set_incols generic, public :: set_nrows => set_lnrows, set_inrows @@ -559,7 +559,7 @@ module psb_base_mat_mod #else generic, public :: set_nrows => set_lnrows generic, public :: set_ncols => set_lncols -#endif +#endif procedure, pass(a) :: set_dupl => psb_lbase_set_dupl procedure, pass(a) :: set_state => psb_lbase_set_state procedure, pass(a) :: set_null => psb_lbase_set_null @@ -580,7 +580,7 @@ module psb_base_mat_mod ! ! Data management ! - ! == = ================================= + ! == = ================================= procedure, pass(a) :: get_neigh => psb_lbase_get_neigh procedure, pass(a) :: free => psb_lbase_free procedure, pass(a) :: asb => psb_lbase_mat_asb @@ -608,7 +608,7 @@ module psb_base_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => psb_lbase_mat_sync procedure, pass(a) :: is_host => psb_lbase_mat_is_host @@ -617,7 +617,7 @@ module psb_base_mat_mod procedure, pass(a) :: set_host => psb_lbase_mat_set_host procedure, pass(a) :: set_dev => psb_lbase_mat_set_dev procedure, pass(a) :: set_sync => psb_lbase_mat_set_sync - + end type psb_lbase_sparse_mat !> Function: psb_lbase_get_nz_row @@ -626,7 +626,7 @@ module psb_base_mat_mod !! count(A(idx,:)/=0) !! \param idx The line we are interested in. ! - interface + interface function psb_lbase_get_nz_row(idx,a) result(res) import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat integer(psb_lpk_), intent(in) :: idx @@ -634,14 +634,14 @@ module psb_base_mat_mod integer(psb_lpk_) :: res end function psb_lbase_get_nz_row end interface - + ! !> Function: psb_lbase_get_nzeros !! \memberof psb_lbase_sparse_mat - !! Interface for the get_nzeros method. Equivalent to: - !! count(A(:,:)/=0) + !! Interface for the get_nzeros method. Equivalent to: + !! count(A(:,:)/=0) ! - interface + interface function psb_lbase_get_nzeros(a) result(res) import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat class(psb_lbase_sparse_mat), intent(in) :: a @@ -654,9 +654,9 @@ module psb_base_mat_mod !! how many items can A hold with !! its current space allocation? !! (as opposed to how many are - !! currently occupied) - ! - interface + !! currently occupied) + ! + interface function psb_lbase_get_size(a) result(res) import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat class(psb_lbase_sparse_mat), intent(in) :: a @@ -668,31 +668,31 @@ module psb_base_mat_mod !> Function reinit: transition state from ASB to UPDATE !! \memberof psb_lbase_sparse_mat !! \param clear [true] explicitly zero out coefficients. - ! - interface + ! + interface subroutine psb_lbase_reinit(a,clear) import :: psb_ipk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(inout) :: a + class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lbase_reinit end interface - + ! !> Function !! \memberof psb_lbase_sparse_mat - !! print on file in Matrix Market format. + !! print on file in Matrix Market format. !! \param iout the output unit !! \param iv(:) [none] renumber both row and column indices !! \param head [none] a descriptive header for the matrix data !! \param ivr(:) [none] renumbering for the rows !! \param ivc(:) [none] renumbering for the cols - ! - interface + ! + interface subroutine psb_lbase_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat integer(psb_ipk_), intent(in) :: iout - class(psb_lbase_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -709,25 +709,25 @@ module psb_base_mat_mod !! Return a list of NZ pairs !! (IA(i),JA(i)) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - ! + ! - interface + interface subroutine psb_lbase_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat @@ -742,7 +742,7 @@ module psb_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lbase_csgetptn end interface - + ! !> Function get_neigh: !! \memberof psb_lbase_sparse_mat @@ -756,21 +756,21 @@ module psb_base_mat_mod !! \param n the number of indices returned !! \param info return code !! \param lev [1] find neighbours recursively for LEV levels, - !! i.e. when lev=2 find neighours of neighbours, etc. - ! - interface + !! i.e. when lev=2 find neighours of neighbours, etc. + ! + interface subroutine psb_lbase_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat - class(psb_lbase_sparse_mat), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev end subroutine psb_lbase_get_neigh end interface - - ! + + ! ! !> Function allocate_mnnz !! \memberof psb_lbase_sparse_mat @@ -780,8 +780,8 @@ module psb_base_mat_mod !! \param n number of cols !! \param nz [estimated internally] number of nonzeros to allocate for ! - interface - subroutine psb_lbase_allocate_mnnz(m,n,a,nz) + interface + subroutine psb_lbase_allocate_mnnz(m,n,a,nz) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat integer(psb_lpk_), intent(in) :: m,n class(psb_lbase_sparse_mat), intent(inout) :: a @@ -789,8 +789,8 @@ module psb_base_mat_mod end subroutine psb_lbase_allocate_mnnz end interface - - ! + + ! ! !> Function reallocate_nz !! \memberof psb_lbase_sparse_mat @@ -798,249 +798,249 @@ module psb_base_mat_mod !! !! \param nz number of nonzeros to allocate for ! - interface - subroutine psb_lbase_reallocate_nz(nz,a) + interface + subroutine psb_lbase_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat integer(psb_lpk_), intent(in) :: nz class(psb_lbase_sparse_mat), intent(inout) :: a end subroutine psb_lbase_reallocate_nz end interface - ! + ! !> Function free !! \memberof psb_lbase_sparse_mat !! \brief destructor ! - interface - subroutine psb_lbase_free(a) + interface + subroutine psb_lbase_free(a) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat class(psb_lbase_sparse_mat), intent(inout) :: a end subroutine psb_lbase_free end interface - - ! - !> Function trim + + ! + !> Function trim !! \memberof psb_lbase_sparse_mat !! \brief Memory trim !! Make sure the memory allocation of the sparse matrix is as tight as - !! possible given the actual number of nonzeros it contains. + !! possible given the actual number of nonzeros it contains. ! - interface - subroutine psb_lbase_trim(a) + interface + subroutine psb_lbase_trim(a) import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat class(psb_lbase_sparse_mat), intent(inout) :: a end subroutine psb_lbase_trim end interface - + interface assignment(=) module procedure psb_base_from_lbase, psb_lbase_from_base end interface assignment(=) - + contains - - ! + + ! !> Function sizeof !! \memberof psb_base_sparse_mat !! \brief Memory occupation in byes ! function psb_base_sizeof(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 8 end function psb_base_sizeof - - ! + + ! !> Function get_fmt !! \memberof psb_base_sparse_mat !! \brief return a short descriptive name (e.g. COO CSR etc.) ! function psb_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'NULL' end function psb_base_get_fmt - ! + ! !> Function has_update !! \memberof psb_base_sparse_mat - !! \brief Does the forma have the UPDATE functionality? + !! \brief Does the forma have the UPDATE functionality? ! function psb_base_has_update() result(res) - implicit none + implicit none logical :: res res = .true. end function psb_base_has_update - + ! - ! Standard getter functions: self-explaining. + ! Standard getter functions: self-explaining. ! function psb_base_get_dupl(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%duplicate end function psb_base_get_dupl - - + + function psb_base_get_state(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%state end function psb_base_get_state - + function psb_base_get_nrows(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%m end function psb_base_get_nrows function psb_base_get_ncols(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%n end function psb_base_get_ncols - subroutine psb_base_set_nrows(m,a) - implicit none + subroutine psb_base_set_nrows(m,a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: m a%m = m end subroutine psb_base_set_nrows - subroutine psb_base_set_ncols(n,a) - implicit none + subroutine psb_base_set_ncols(n,a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: n a%n = n end subroutine psb_base_set_ncols - - subroutine psb_base_set_state(n,a) - implicit none + + subroutine psb_base_set_state(n,a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: n a%state = n end subroutine psb_base_set_state - subroutine psb_base_set_dupl(n,a) - implicit none + subroutine psb_base_set_dupl(n,a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: n a%duplicate = n end subroutine psb_base_set_dupl - subroutine psb_base_set_null(a) - implicit none + subroutine psb_base_set_null(a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_null_ end subroutine psb_base_set_null - subroutine psb_base_set_bld(a) - implicit none + subroutine psb_base_set_bld(a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_bld_ end subroutine psb_base_set_bld - subroutine psb_base_set_upd(a) - implicit none + subroutine psb_base_set_upd(a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_upd_ end subroutine psb_base_set_upd - subroutine psb_base_set_asb(a) - implicit none + subroutine psb_base_set_asb(a) + implicit none class(psb_base_sparse_mat), intent(inout) :: a a%state = psb_spmat_asb_ end subroutine psb_base_set_asb - subroutine psb_base_set_sorted(a,val) - implicit none + subroutine psb_base_set_sorted(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%sorted = val else a%sorted = .true. end if end subroutine psb_base_set_sorted - subroutine psb_base_set_triangle(a,val) - implicit none + subroutine psb_base_set_triangle(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%triangle = val else a%triangle = .true. end if end subroutine psb_base_set_triangle - subroutine psb_base_set_symmetric(a,val) - implicit none + subroutine psb_base_set_symmetric(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%symmetric = val else a%symmetric = .true. end if end subroutine psb_base_set_symmetric - subroutine psb_base_set_unit(a,val) - implicit none + subroutine psb_base_set_unit(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%unitd = val else a%unitd = .true. end if end subroutine psb_base_set_unit - subroutine psb_base_set_lower(a,val) - implicit none + subroutine psb_base_set_lower(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%upper = .not.val else a%upper = .false. end if end subroutine psb_base_set_lower - subroutine psb_base_set_upper(a,val) - implicit none + subroutine psb_base_set_upper(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%upper = val else a%upper = .true. end if end subroutine psb_base_set_upper - subroutine psb_base_set_repeatable_updates(a,val) - implicit none + subroutine psb_base_set_repeatable_updates(a,val) + implicit none class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%repeatable_updates = val else a%repeatable_updates = .true. @@ -1048,70 +1048,70 @@ contains end subroutine psb_base_set_repeatable_updates function psb_base_is_triangle(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%triangle end function psb_base_is_triangle function psb_base_is_symmetric(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%symmetric end function psb_base_is_symmetric function psb_base_is_unit(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%unitd end function psb_base_is_unit function psb_base_is_upper(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%upper .and. a%triangle end function psb_base_is_upper function psb_base_is_lower(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (.not.a%upper) .and. a%triangle end function psb_base_is_lower function psb_base_is_null(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_null_) end function psb_base_is_null function psb_base_is_bld(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_bld_) end function psb_base_is_bld function psb_base_is_upd(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_upd_) end function psb_base_is_upd function psb_base_is_asb(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_asb_) end function psb_base_is_asb function psb_base_is_sorted(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%sorted @@ -1119,21 +1119,21 @@ contains function psb_base_is_by_rows(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = .false. end function psb_base_is_by_rows function psb_base_is_by_cols(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = .false. end function psb_base_is_by_cols function psb_base_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res res = a%repeatable_updates @@ -1141,27 +1141,27 @@ contains ! ! has_xt_tri: does the current type support - ! extended triangle operations? - ! + ! extended triangle operations? + ! function psb_base_has_xt_tri() result(res) - implicit none + implicit none logical :: res - - res = .false. + + res = .false. end function psb_base_has_xt_tri - + ! ! TRANSP: note sorted=.false. ! better invoke a fix() too many than ! regret it later... ! subroutine psb_base_transp_2mat(a,b) - implicit none - + implicit none + class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b - + b%m = a%n b%n = a%m b%state = a%state @@ -1172,16 +1172,16 @@ contains b%upper = .not.a%upper b%sorted = .false. b%repeatable_updates = .false. - + end subroutine psb_base_transp_2mat subroutine psb_base_transc_2mat(a,b) - implicit none - + implicit none + class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b - + b%m = a%n b%n = a%m b%state = a%state @@ -1196,8 +1196,8 @@ contains end subroutine psb_base_transc_2mat subroutine psb_base_transp_1mat(a) - implicit none - + implicit none + class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: itmp @@ -1211,15 +1211,15 @@ contains a%upper = .not.a%upper a%sorted = .false. a%repeatable_updates = .false. - + end subroutine psb_base_transp_1mat subroutine psb_base_transc_1mat(a) - implicit none - + implicit none + class(psb_base_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() end subroutine psb_base_transc_1mat @@ -1228,89 +1228,89 @@ contains !> Function base_asb: !! \memberof psb_base_sparse_mat !! \brief Sync: base version calls sync and the set_asb. - !! + !! ! subroutine psb_base_mat_asb(a) - implicit none + implicit none class(psb_base_sparse_mat), intent(inout) :: a - + call a%sync() call a%set_asb() end subroutine psb_base_mat_asb ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_base_sparse_mat !! \brief Sync: base version is a no-op. - !! + !! ! subroutine psb_base_mat_sync(a) - implicit none + implicit none class(psb_base_sparse_mat), target, intent(in) :: a - + end subroutine psb_base_mat_sync ! !> Function base_set_host: !! \memberof psb_base_sparse_mat !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine psb_base_mat_set_host(a) - implicit none + implicit none class(psb_base_sparse_mat), intent(inout) :: a - + end subroutine psb_base_mat_set_host ! !> Function base_set_dev: !! \memberof psb_base_sparse_mat !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine psb_base_mat_set_dev(a) - implicit none + implicit none class(psb_base_sparse_mat), intent(inout) :: a - + end subroutine psb_base_mat_set_dev ! !> Function base_set_sync: !! \memberof psb_base_sparse_mat !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine psb_base_mat_set_sync(a) - implicit none + implicit none class(psb_base_sparse_mat), intent(inout) :: a - + end subroutine psb_base_mat_set_sync ! !> Function base_is_dev: !! \memberof psb_base_sparse_mat !! \brief Is matrix on eaternal device . - !! + !! ! function psb_base_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res - + res = .false. end function psb_base_mat_is_dev - + ! !> Function base_is_host !! \memberof psb_base_sparse_mat !! \brief Is matrix on standard memory . - !! + !! ! function psb_base_mat_is_host(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res @@ -1321,10 +1321,10 @@ contains !> Function base_is_sync !! \memberof psb_base_sparse_mat !! \brief Is matrix on sync . - !! + !! ! function psb_base_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_base_sparse_mat), intent(in) :: a logical :: res @@ -1332,225 +1332,225 @@ contains end function psb_base_mat_is_sync - - ! + + ! !> Function sizeof !! \memberof psb_lbase_sparse_mat !! \brief Memory occupation in byes ! function psb_lbase_sizeof(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 8 end function psb_lbase_sizeof - - ! + + ! !> Function get_fmt !! \memberof psb_lbase_sparse_mat !! \brief return a short descriptive name (e.g. COO CSR etc.) ! function psb_lbase_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'NULL' end function psb_lbase_get_fmt - ! + ! !> Function has_update !! \memberof psb_lbase_sparse_mat - !! \brief Does the forma have the UPDATE functionality? + !! \brief Does the forma have the UPDATE functionality? ! function psb_lbase_has_update() result(res) - implicit none + implicit none logical :: res res = .true. end function psb_lbase_has_update - + ! - ! Standard getter functions: self-explaining. + ! Standard getter functions: self-explaining. ! function psb_lbase_get_dupl(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%duplicate end function psb_lbase_get_dupl - - + + function psb_lbase_get_state(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%state end function psb_lbase_get_state - + function psb_lbase_get_nrows(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%m end function psb_lbase_get_nrows function psb_lbase_get_ncols(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%n end function psb_lbase_get_ncols - subroutine psb_lbase_set_lnrows(m,a) - implicit none + subroutine psb_lbase_set_lnrows(m,a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: m a%m = m end subroutine psb_lbase_set_lnrows - subroutine psb_lbase_set_lncols(n,a) - implicit none + subroutine psb_lbase_set_lncols(n,a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: n a%n = n end subroutine psb_lbase_set_lncols -#if defined(IPK4) && defined(LPK8) - subroutine psb_lbase_set_inrows(m,a) - implicit none +#if defined(IPK4) && defined(LPK8) + subroutine psb_lbase_set_inrows(m,a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: m ! This cannot overflow, since ipk_ <= lpk_ a%m = m end subroutine psb_lbase_set_inrows - subroutine psb_lbase_set_incols(n,a) - implicit none + subroutine psb_lbase_set_incols(n,a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: n ! This cannot overflow, since ipk_ <= lpk_ a%n = n end subroutine psb_lbase_set_incols -#endif +#endif - subroutine psb_lbase_set_state(n,a) - implicit none + subroutine psb_lbase_set_state(n,a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: n a%state = n end subroutine psb_lbase_set_state - subroutine psb_lbase_set_dupl(n,a) - implicit none + subroutine psb_lbase_set_dupl(n,a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: n a%duplicate = n end subroutine psb_lbase_set_dupl - subroutine psb_lbase_set_null(a) - implicit none + subroutine psb_lbase_set_null(a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a a%state = psb_spmat_null_ end subroutine psb_lbase_set_null - subroutine psb_lbase_set_bld(a) - implicit none + subroutine psb_lbase_set_bld(a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a a%state = psb_spmat_bld_ end subroutine psb_lbase_set_bld - subroutine psb_lbase_set_upd(a) - implicit none + subroutine psb_lbase_set_upd(a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a a%state = psb_spmat_upd_ end subroutine psb_lbase_set_upd - subroutine psb_lbase_set_asb(a) - implicit none + subroutine psb_lbase_set_asb(a) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a a%state = psb_spmat_asb_ end subroutine psb_lbase_set_asb - subroutine psb_lbase_set_sorted(a,val) - implicit none + subroutine psb_lbase_set_sorted(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%sorted = val else a%sorted = .true. end if end subroutine psb_lbase_set_sorted - subroutine psb_lbase_set_triangle(a,val) - implicit none + subroutine psb_lbase_set_triangle(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%triangle = val else a%triangle = .true. end if end subroutine psb_lbase_set_triangle - subroutine psb_lbase_set_symmetric(a,val) - implicit none + subroutine psb_lbase_set_symmetric(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%symmetric = val else a%symmetric = .true. end if end subroutine psb_lbase_set_symmetric - subroutine psb_lbase_set_unit(a,val) - implicit none + subroutine psb_lbase_set_unit(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%unitd = val else a%unitd = .true. end if end subroutine psb_lbase_set_unit - subroutine psb_lbase_set_lower(a,val) - implicit none + subroutine psb_lbase_set_lower(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%upper = .not.val else a%upper = .false. end if end subroutine psb_lbase_set_lower - subroutine psb_lbase_set_upper(a,val) - implicit none + subroutine psb_lbase_set_upper(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%upper = val else a%upper = .true. end if end subroutine psb_lbase_set_upper - subroutine psb_lbase_set_repeatable_updates(a,val) - implicit none + subroutine psb_lbase_set_repeatable_updates(a,val) + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a logical, intent(in), optional :: val - - if (present(val)) then + + if (present(val)) then a%repeatable_updates = val else a%repeatable_updates = .true. @@ -1559,80 +1559,80 @@ contains ! ! has_xt_tri: does the current type support - ! extended triangle operations? - ! + ! extended triangle operations? + ! function psb_lbase_has_xt_tri() result(res) - implicit none + implicit none logical :: res - - res = .false. + + res = .false. end function psb_lbase_has_xt_tri function psb_lbase_is_triangle(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = a%triangle end function psb_lbase_is_triangle function psb_lbase_is_symmetric(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = a%symmetric end function psb_lbase_is_symmetric function psb_lbase_is_unit(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = a%unitd end function psb_lbase_is_unit function psb_lbase_is_upper(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = a%upper .and. a%triangle end function psb_lbase_is_upper function psb_lbase_is_lower(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = (.not.a%upper) .and. a%triangle end function psb_lbase_is_lower function psb_lbase_is_null(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_null_) end function psb_lbase_is_null function psb_lbase_is_bld(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_bld_) end function psb_lbase_is_bld function psb_lbase_is_upd(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_upd_) end function psb_lbase_is_upd function psb_lbase_is_asb(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = (a%state == psb_spmat_asb_) end function psb_lbase_is_asb function psb_lbase_is_sorted(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = a%sorted @@ -1640,38 +1640,38 @@ contains function psb_lbase_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = .false. end function psb_lbase_is_by_rows function psb_lbase_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = .false. end function psb_lbase_is_by_cols function psb_lbase_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res res = a%repeatable_updates end function psb_lbase_is_repeatable_updates - + ! ! TRANSP: note sorted=.false. ! better invoke a fix() too many than ! regret it later... ! subroutine psb_lbase_transp_2mat(a,b) - implicit none - + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b - + b%m = a%n b%n = a%m b%state = a%state @@ -1681,16 +1681,16 @@ contains b%upper = .not.a%upper b%sorted = .false. b%repeatable_updates = .false. - + end subroutine psb_lbase_transp_2mat subroutine psb_lbase_transc_2mat(a,b) - implicit none - + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b - + b%m = a%n b%n = a%m b%state = a%state @@ -1704,8 +1704,8 @@ contains end subroutine psb_lbase_transc_2mat subroutine psb_lbase_transp_1mat(a) - implicit none - + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: itmp @@ -1719,15 +1719,15 @@ contains a%upper = .not.a%upper a%sorted = .false. a%repeatable_updates = .false. - + end subroutine psb_lbase_transp_1mat subroutine psb_lbase_transc_1mat(a) - implicit none - + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() end subroutine psb_lbase_transc_1mat @@ -1736,89 +1736,89 @@ contains !> Function base_asb: !! \memberof psb_lbase_sparse_mat !! \brief Sync: base version calls sync and the set_asb. - !! + !! ! subroutine psb_lbase_mat_asb(a) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - + call a%sync() call a%set_asb() end subroutine psb_lbase_mat_asb ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_lbase_sparse_mat !! \brief Sync: base version is a no-op. - !! + !! ! subroutine psb_lbase_mat_sync(a) - implicit none + implicit none class(psb_lbase_sparse_mat), target, intent(in) :: a - + end subroutine psb_lbase_mat_sync ! !> Function base_set_host: !! \memberof psb_lbase_sparse_mat !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine psb_lbase_mat_set_host(a) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - + end subroutine psb_lbase_mat_set_host ! !> Function base_set_dev: !! \memberof psb_lbase_sparse_mat !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine psb_lbase_mat_set_dev(a) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - + end subroutine psb_lbase_mat_set_dev ! !> Function base_set_sync: !! \memberof psb_lbase_sparse_mat !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine psb_lbase_mat_set_sync(a) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(inout) :: a - + end subroutine psb_lbase_mat_set_sync ! !> Function base_is_dev: !! \memberof psb_lbase_sparse_mat !! \brief Is matrix on eaternal device . - !! + !! ! function psb_lbase_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res - + res = .false. end function psb_lbase_mat_is_dev - + ! !> Function base_is_host !! \memberof psb_lbase_sparse_mat !! \brief Is matrix on standard memory . - !! + !! ! function psb_lbase_mat_is_host(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res @@ -1829,10 +1829,10 @@ contains !> Function base_is_sync !! \memberof psb_lbase_sparse_mat !! \brief Is matrix on sync . - !! + !! ! function psb_lbase_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_lbase_sparse_mat), intent(in) :: a logical :: res @@ -1844,33 +1844,32 @@ contains type(psb_lbase_sparse_mat), intent(inout) :: lb type(psb_base_sparse_mat), intent(in) :: ib - lb%m = ib%m - lb%n = ib%n - lb%state = ib%state - lb%duplicate = ib%duplicate - lb%triangle = ib%triangle - lb%unitd = ib%unitd - lb%upper = ib%upper - lb%sorted = ib%sorted - lb%repeatable_updates = ib%repeatable_updates - + lb%m = ib%m + lb%n = ib%n + lb%state = ib%state + lb%duplicate = ib%duplicate + lb%triangle = ib%triangle + lb%unitd = ib%unitd + lb%upper = ib%upper + lb%sorted = ib%sorted + lb%repeatable_updates = ib%repeatable_updates + end subroutine psb_lbase_from_base subroutine psb_base_from_lbase(ib,lb) type(psb_base_sparse_mat), intent(inout) :: ib type(psb_lbase_sparse_mat), intent(in) :: lb - - ib%m = lb%m - ib%n = lb%n - ib%state = lb%state - ib%duplicate = lb%duplicate - ib%triangle = lb%triangle - ib%unitd = lb%unitd - ib%upper = lb%upper - ib%sorted = lb%sorted - ib%repeatable_updates = lb%repeatable_updates - + + ib%m = lb%m + ib%n = lb%n + ib%state = lb%state + ib%duplicate = lb%duplicate + ib%triangle = lb%triangle + ib%unitd = lb%unitd + ib%upper = lb%upper + ib%sorted = lb%sorted + ib%repeatable_updates = lb%repeatable_updates + end subroutine psb_base_from_lbase end module psb_base_mat_mod - diff --git a/base/modules/serial/psb_c_base_mat_mod.F90 b/base/modules/serial/psb_c_base_mat_mod.F90 index 66d76a1c5..6924d8198 100644 --- a/base/modules/serial/psb_c_base_mat_mod.F90 +++ b/base/modules/serial/psb_c_base_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,12 +27,12 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! module psb_c_base_mat_mod - + use psb_base_mat_mod use psb_c_base_vect_mod @@ -56,59 +56,59 @@ module psb_c_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_c_base_csput_a - procedure, pass(a) :: csput_v => psb_c_base_csput_v + procedure, pass(a) :: csput_v => psb_c_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_c_base_csgetrow procedure, pass(a) :: csgetblk => psb_c_base_csgetblk procedure, pass(a) :: get_diag => psb_c_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_c_base_tril procedure, pass(a) :: triu => psb_c_base_triu - procedure, pass(a) :: csclip => psb_c_base_csclip - procedure, pass(a) :: cp_to_coo => psb_c_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_c_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_c_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_c_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_c_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_c_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_c_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_c_base_mv_from_fmt - procedure, pass(a) :: mold => psb_c_base_mold + procedure, pass(a) :: csclip => psb_c_base_csclip + procedure, pass(a) :: cp_to_coo => psb_c_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_c_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_c_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_c_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_c_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_c_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_c_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_c_base_mv_from_fmt + procedure, pass(a) :: mold => psb_c_base_mold procedure, pass(a) :: clone => psb_c_base_clone procedure, pass(a) :: make_nonunit => psb_c_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_c_base_clean_zeros ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_c_base_cp_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_c_base_cp_from_lcoo - procedure, pass(a) :: cp_to_lfmt => psb_c_base_cp_to_lfmt - procedure, pass(a) :: cp_from_lfmt => psb_c_base_cp_from_lfmt - procedure, pass(a) :: mv_to_lcoo => psb_c_base_mv_to_lcoo - procedure, pass(a) :: mv_from_lcoo => psb_c_base_mv_from_lcoo - procedure, pass(a) :: mv_to_lfmt => psb_c_base_mv_to_lfmt - procedure, pass(a) :: mv_from_lfmt => psb_c_base_mv_from_lfmt + procedure, pass(a) :: cp_to_lcoo => psb_c_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_c_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_c_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_c_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_c_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_c_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_c_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_c_base_mv_from_lfmt + - ! - ! Transpose methods: defined here but not implemented. - ! + ! Transpose methods: defined here but not implemented. + ! procedure, pass(a) :: transp_1mat => psb_c_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_c_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_c_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_c_base_transc_2mat - + + ! + ! Computational methods: defined here but not implemented. ! - ! Computational methods: defined here but not implemented. - ! procedure, pass(a) :: vect_mv => psb_c_base_vect_mv procedure, pass(a) :: csmv => psb_c_base_csmv procedure, pass(a) :: csmm => psb_c_base_csmm generic, public :: spmm => csmm, csmv, vect_mv procedure, pass(a) :: in_vect_sv => psb_c_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_c_base_inner_cssv + procedure, pass(a) :: inner_cssv => psb_c_base_inner_cssv procedure, pass(a) :: inner_cssm => psb_c_base_inner_cssm generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv procedure, pass(a) :: vect_cssv => psb_c_base_vect_cssv @@ -125,15 +125,20 @@ module psb_c_base_mat_mod procedure, pass(a) :: arwsum => psb_c_base_arwsum procedure, pass(a) :: colsum => psb_c_base_colsum procedure, pass(a) :: aclsum => psb_c_base_aclsum + procedure, pass(a) :: scalpid => psb_c_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_c_base_spaxpby + procedure, pass(a) :: cmpval => psb_c_base_cmpval + procedure, pass(a) :: cmpmat => psb_c_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_c_base_sparse_mat - + private :: c_base_mat_sync, c_base_mat_is_host, c_base_mat_is_dev, & & c_base_mat_is_sync, c_base_mat_set_host, c_base_mat_set_dev,& & c_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_c_coo_sparse_mat !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat - !! + !! !! psb_c_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -147,15 +152,15 @@ module psb_c_base_mat_mod integer(psb_ipk_), allocatable :: ia(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_spk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => c_coo_get_size procedure, pass(a) :: get_nzeros => c_coo_get_nzeros procedure, nopass :: get_fmt => c_coo_get_fmt @@ -175,9 +180,9 @@ module psb_c_base_mat_mod ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_c_cp_coo_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_c_cp_coo_from_lcoo - + procedure, pass(a) :: cp_to_lcoo => psb_c_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_c_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_c_coo_csput_a procedure, pass(a) :: get_diag => psb_c_coo_get_diag procedure, pass(a) :: csgetrow => psb_c_coo_csgetrow @@ -203,18 +208,18 @@ module psb_c_base_mat_mod ! This is COO specific ! procedure, pass(a) :: set_nzeros => c_coo_set_nzeros - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => c_coo_transp_1mat procedure, pass(a) :: transc_1mat => c_coo_transc_1mat ! - ! Computational methods. - ! + ! Computational methods. + ! procedure, pass(a) :: csmm => psb_c_coo_csmm procedure, pass(a) :: csmv => psb_c_coo_csmv procedure, pass(a) :: inner_cssm => psb_c_coo_cssm @@ -228,14 +233,17 @@ module psb_c_base_mat_mod procedure, pass(a) :: arwsum => psb_c_coo_arwsum procedure, pass(a) :: colsum => psb_c_coo_colsum procedure, pass(a) :: aclsum => psb_c_coo_aclsum - + procedure, pass(a) :: scalpid => psb_c_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_c_coo_spaxpby + procedure, pass(a) :: cmpval => psb_c_coo_cmpval + procedure, pass(a) :: cmpmat => psb_c_coo_cmpmat end type psb_c_coo_sparse_mat - + private :: c_coo_get_nzeros, c_coo_set_nzeros, & & c_coo_get_fmt, c_coo_free, c_coo_sizeof, & & c_coo_transp_1mat, c_coo_transc_1mat - - + + !> \namespace psb_base_mod \class psb_lc_base_sparse_mat !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat !! The psb_lc_base_sparse_mat type, extending psb_base_sparse_mat, @@ -255,33 +263,33 @@ module psb_c_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_lc_base_csput_a - procedure, pass(a) :: csput_v => psb_lc_base_csput_v + procedure, pass(a) :: csput_v => psb_lc_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_lc_base_csgetrow procedure, pass(a) :: csgetblk => psb_lc_base_csgetblk procedure, pass(a) :: get_diag => psb_lc_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_lc_base_tril procedure, pass(a) :: triu => psb_lc_base_triu - procedure, pass(a) :: csclip => psb_lc_base_csclip - procedure, pass(a) :: cp_to_coo => psb_lc_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_lc_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_lc_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_lc_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_lc_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_lc_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_lc_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_lc_base_mv_from_fmt - procedure, pass(a) :: mold => psb_lc_base_mold + procedure, pass(a) :: csclip => psb_lc_base_csclip + procedure, pass(a) :: cp_to_coo => psb_lc_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_lc_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lc_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lc_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lc_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_lc_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lc_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lc_base_mv_from_fmt + procedure, pass(a) :: mold => psb_lc_base_mold procedure, pass(a) :: clone => psb_lc_base_clone procedure, pass(a) :: make_nonunit => psb_lc_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_lc_base_clean_zeros ! - ! Computational methods: defined here but not implemented. - ! + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_lc_base_scals procedure, pass(a) :: scalv => psb_lc_base_scal generic, public :: scal => scals, scalv @@ -292,35 +300,40 @@ module psb_c_base_mat_mod procedure, pass(a) :: arwsum => psb_lc_base_arwsum procedure, pass(a) :: colsum => psb_lc_base_colsum procedure, pass(a) :: aclsum => psb_lc_base_aclsum + procedure, pass(a) :: scalpid => psb_lc_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_lc_base_spaxpby + procedure, pass(a) :: cmpval => psb_lc_base_cmpval + procedure, pass(a) :: cmpmat => psb_lc_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_icoo => psb_lc_base_cp_to_icoo - procedure, pass(a) :: cp_from_icoo => psb_lc_base_cp_from_icoo - procedure, pass(a) :: cp_to_ifmt => psb_lc_base_cp_to_ifmt - procedure, pass(a) :: cp_from_ifmt => psb_lc_base_cp_from_ifmt - procedure, pass(a) :: mv_to_icoo => psb_lc_base_mv_to_icoo - procedure, pass(a) :: mv_from_icoo => psb_lc_base_mv_from_icoo - procedure, pass(a) :: mv_to_ifmt => psb_lc_base_mv_to_ifmt - procedure, pass(a) :: mv_from_ifmt => psb_lc_base_mv_from_ifmt - + procedure, pass(a) :: cp_to_icoo => psb_lc_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_lc_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_lc_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_lc_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_lc_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_lc_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_lc_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_lc_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. ! - ! Transpose methods: defined here but not implemented. - ! procedure, pass(a) :: transp_1mat => psb_lc_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_lc_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_lc_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_lc_base_transc_2mat - + end type psb_lc_base_sparse_mat - + private :: lc_base_mat_sync, lc_base_mat_is_host, lc_base_mat_is_dev, & & lc_base_mat_is_sync, lc_base_mat_set_host, lc_base_mat_set_dev,& & lc_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_lc_coo_sparse_mat !! \extends psb_lc_base_mat_mod::psb_lc_base_sparse_mat - !! + !! !! psb_lc_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -334,15 +347,15 @@ module psb_c_base_mat_mod integer(psb_lpk_), allocatable :: ia(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_spk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => lc_coo_get_size procedure, pass(a) :: get_nzeros => lc_coo_get_nzeros procedure, nopass :: get_fmt => lc_coo_get_fmt @@ -360,7 +373,7 @@ module psb_c_base_mat_mod procedure, pass(a) :: mv_from_fmt => psb_lc_mv_coo_from_fmt procedure, pass(a) :: cp_to_icoo => psb_lc_cp_coo_to_icoo procedure, pass(a) :: cp_from_icoo => psb_lc_cp_coo_from_icoo - + procedure, pass(a) :: csput_a => psb_lc_coo_csput_a procedure, pass(a) :: get_diag => psb_lc_coo_get_diag procedure, pass(a) :: csgetrow => psb_lc_coo_csgetrow @@ -382,9 +395,9 @@ module psb_c_base_mat_mod procedure, pass(a) :: set_sort_status => lc_coo_set_sort_status procedure, pass(a) :: get_sort_status => lc_coo_get_sort_status - - ! Computational methods: defined here but not implemented. - ! + + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_lc_coo_scals procedure, pass(a) :: scalv => psb_lc_coo_scal procedure, pass(a) :: maxval => psb_lc_coo_maxval @@ -394,7 +407,10 @@ module psb_c_base_mat_mod procedure, pass(a) :: arwsum => psb_lc_coo_arwsum procedure, pass(a) :: colsum => psb_lc_coo_colsum procedure, pass(a) :: aclsum => psb_lc_coo_aclsum - + procedure, pass(a) :: scalpid => psb_lc_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_lc_coo_spaxpby + procedure, pass(a) :: cmpval => psb_lc_coo_cmpval + procedure, pass(a) :: cmpmat => psb_lc_coo_cmpmat ! ! This is COO specific ! @@ -406,25 +422,25 @@ module psb_c_base_mat_mod procedure, pass(a) :: iset_nzeros => lc_coo_iset_nzeros generic, public :: set_nzeros => iset_nzeros #endif - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => lc_coo_transp_1mat procedure, pass(a) :: transc_1mat => lc_coo_transc_1mat - + end type psb_lc_coo_sparse_mat - + private :: lc_coo_get_nzeros, lc_coo_iset_nzeros, & & lc_coo_get_fmt, lc_coo_free, lc_coo_sizeof, & & lc_coo_transp_1mat, lc_coo_transc_1mat #if defined(IPK4) && defined(LPK8) private :: lc_coo_lset_nzeros #endif - + ! == ================= ! ! BASE interfaces @@ -433,14 +449,14 @@ module psb_c_base_mat_mod !> Function csput: !! \memberof psb_c_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -453,33 +469,33 @@ module psb_c_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_csput_a end interface - - interface - subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -487,43 +503,43 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_c_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_c_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -536,33 +552,33 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_c_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_c_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -573,34 +589,34 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_c_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_c_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -621,27 +637,27 @@ module psb_c_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_c_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -650,13 +666,13 @@ module psb_c_base_mat_mod class(psb_c_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_c_base_tril end interface - + ! !> Function triu: !! \memberof psb_c_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -665,27 +681,27 @@ module psb_c_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_c_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -694,27 +710,27 @@ module psb_c_base_mat_mod class(psb_c_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_c_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_c_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_c_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_c_base_get_diag(a,d,info) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_c_base_sparse_mat @@ -724,10 +740,10 @@ module psb_c_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mold(a,b,info) - import + ! + interface + subroutine psb_c_base_mold(a,b,info) + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -739,21 +755,21 @@ module psb_c_base_mat_mod !> Function clone: !! \memberof psb_c_base_sparse_mat !! \brief Allocate and clone a class(psb_c_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_c_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_clone end interface @@ -763,18 +779,18 @@ module psb_c_base_mat_mod !> Function make_nonunit: !! \memberof psb_c_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_c_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a end subroutine psb_c_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_c_base_sparse_mat @@ -782,16 +798,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_to_coo(a,b,info) + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_c_base_sparse_mat @@ -799,16 +815,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_from_coo(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_c_base_sparse_mat @@ -817,16 +833,16 @@ module psb_c_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_to_fmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_c_base_sparse_mat @@ -835,16 +851,16 @@ module psb_c_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_from_fmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_c_base_sparse_mat @@ -852,16 +868,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_to_coo(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_c_base_sparse_mat @@ -869,16 +885,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_from_coo(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_c_base_sparse_mat @@ -887,16 +903,16 @@ module psb_c_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_to_fmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_c_base_sparse_mat @@ -905,10 +921,10 @@ module psb_c_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_from_fmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -921,16 +937,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_to_lcoo(a,b,info) + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_to_lcoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_c_base_sparse_mat @@ -938,16 +954,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_from_lcoo(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_from_lcoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_c_base_sparse_mat @@ -956,16 +972,16 @@ module psb_c_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_to_lfmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_to_lfmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_c_base_sparse_mat @@ -974,16 +990,16 @@ module psb_c_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_cp_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_c_base_cp_from_lfmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_cp_from_lfmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_c_base_sparse_mat @@ -991,16 +1007,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_to_lcoo(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_to_lcoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_c_base_sparse_mat @@ -1008,16 +1024,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_from_lcoo(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_from_lcoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_c_base_sparse_mat @@ -1026,16 +1042,16 @@ module psb_c_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_to_lfmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_to_lfmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_c_base_sparse_mat @@ -1044,10 +1060,10 @@ module psb_c_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_c_base_mv_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_c_base_mv_from_lfmt(a,b,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1056,78 +1072,78 @@ module psb_c_base_mat_mod ! - !> + !> !! \memberof psb_c_base_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_clean_zeros ! interface subroutine psb_c_base_clean_zeros(a, info) - import + import class(psb_c_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_clean_zeros end interface - + ! !> Function transp: !! \memberof psb_c_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_c_base_transp_2mat(a,b) - import + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_c_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_c_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_c_base_transc_2mat(a,b) - import + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_c_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_c_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_c_base_transp_1mat(a) - import + import class(psb_c_base_sparse_mat), intent(inout) :: a end subroutine psb_c_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_c_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_c_base_transc_1mat(a) - import + import class(psb_c_base_sparse_mat), intent(inout) :: a end subroutine psb_c_base_transc_1mat end interface - + ! !> Function csmm: !! \memberof psb_c_base_sparse_mat @@ -1146,9 +1162,9 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! ! - interface + interface subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) - import + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1156,7 +1172,7 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_base_csmm end interface - + !> Function csmv: !! \memberof psb_c_base_sparse_mat !! \brief Product by a dense rank 1 array. @@ -1174,9 +1190,9 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1184,7 +1200,7 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_base_csmv end interface - + !> Function vect_mv: !! \memberof psb_c_base_sparse_mat !! \brief Product by an encapsulated array type(psb_c_vect_type) @@ -1196,7 +1212,7 @@ module psb_c_base_mat_mod !! versions with the standard arrays. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1209,9 +1225,9 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x @@ -1220,7 +1236,7 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_base_vect_mv end interface - + ! !> Function cssm: !! \memberof psb_c_base_sparse_mat @@ -1229,7 +1245,7 @@ module psb_c_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssm. + !! Internal workhorse called by cssm. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1241,9 +1257,9 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1251,8 +1267,8 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_base_inner_cssm end interface - - + + ! !> Function cssv: !! \memberof psb_c_base_sparse_mat @@ -1261,7 +1277,7 @@ module psb_c_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssv. + !! Internal workhorse called by cssv. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1273,12 +1289,12 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface - subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1286,7 +1302,7 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_base_inner_cssv end interface - + ! !> Function inner_vect_cssv: !! \memberof psb_c_base_sparse_mat @@ -1296,10 +1312,10 @@ module psb_c_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by vect_cssv. + !! Internal workhorse called by vect_cssv. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1311,9 +1327,9 @@ module psb_c_base_mat_mod !! \param trans [N] Whether to use A (N), its transpose (T) !! or its conjugate transpose (C) ! - interface - subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x, y @@ -1321,7 +1337,7 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_base_inner_vect_sv end interface - + ! !> Function cssm: !! \memberof psb_c_base_sparse_mat @@ -1340,12 +1356,12 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1354,7 +1370,7 @@ module psb_c_base_mat_mod complex(psb_spk_), intent(in), optional :: d(:) end subroutine psb_c_base_cssm end interface - + ! !> Function cssv: !! \memberof psb_c_base_sparse_mat @@ -1373,12 +1389,12 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1387,7 +1403,7 @@ module psb_c_base_mat_mod complex(psb_spk_), intent(in), optional :: d(:) end subroutine psb_c_base_cssv end interface - + ! !> Function vect_cssv: !! \memberof psb_c_base_sparse_mat @@ -1407,12 +1423,12 @@ module psb_c_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. + !! \param D [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x,y @@ -1421,24 +1437,24 @@ module psb_c_base_mat_mod class(psb_c_base_vect_type), optional, intent(inout) :: d end subroutine psb_c_base_vect_cssv end interface - + ! !> Function base_scals: !! \memberof psb_c_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_c_base_scals(d,a,info) - import + interface + subroutine psb_c_base_scals(d,a,info) + import class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_scals end interface - + ! !> Function base_scal: !! \memberof psb_c_base_sparse_mat @@ -1448,40 +1464,125 @@ module psb_c_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_c_base_scal(d,a,info,side) - import + interface + subroutine psb_c_base_scal(d,a,info,side) + import class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_c_base_scal end interface - + + ! + !> Function base_scalplusidentity: + !! \memberof psb_c_base_sparse_mat + !! \brief Scale a matrix by a vector and sums an identity + !! + !! \param d Scaling + !! \param info return code + ! + interface + subroutine psb_c_base_scalplusidentity(d,a,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_scalplusidentity + end interface + + ! + !> Function base_spaxpby: + !! \memberof psb_c_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_c_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_spaxpby + end interface + + ! + !> Function base_cmpval: + !! \memberof psb_c_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_c_base_cmpval(a,val,tol,info) result(res) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_c_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_c_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_c_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_c_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_c_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_c_base_maxval(a) result(res) - import + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_c_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_c_base_csnmi(a) result(res) - import + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_base_csnmi @@ -1492,11 +1593,11 @@ module psb_c_base_mat_mod !> Function base_csnmi: !! \memberof psb_c_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_c_base_csnm1(a) result(res) - import + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_base_csnm1 @@ -1508,11 +1609,11 @@ module psb_c_base_mat_mod !! \memberof psb_c_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_c_base_rowsum(d,a) - import + interface + subroutine psb_c_base_rowsum(d,a) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_rowsum @@ -1523,26 +1624,26 @@ module psb_c_base_mat_mod !! \memberof psb_c_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_c_base_arwsum(d,a) - import + !! + interface + subroutine psb_c_base_arwsum(d,a) + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_c_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_c_base_colsum(d,a) - import + interface + subroutine psb_c_base_colsum(d,a) + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_colsum @@ -1553,16 +1654,16 @@ module psb_c_base_mat_mod !! \memberof psb_c_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_c_base_aclsum(d,a) - import + !! + interface + subroutine psb_c_base_aclsum(d,a) + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_aclsum end interface - + ! == =============== ! ! COO interfaces @@ -1570,76 +1671,76 @@ module psb_c_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_c_coo_reallocate_nz(nz,a) - import + subroutine psb_c_coo_reallocate_nz(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a end subroutine psb_c_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_c_coo_sparse_mat ! interface - subroutine psb_c_coo_ensure_size(nz,a) - import + subroutine psb_c_coo_ensure_size(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a end subroutine psb_c_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_c_coo_reinit(a,clear) - import - class(psb_c_coo_sparse_mat), intent(inout) :: a + import + class(psb_c_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_coo_reinit end interface ! - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_c_coo_trim(a) - import + import class(psb_c_coo_sparse_mat), intent(inout) :: a end subroutine psb_c_coo_trim end interface ! - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_clean_zeros ! interface subroutine psb_c_coo_clean_zeros(a,info) - import + import class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_clean_zeros end interface ! - !> + !> !! \memberof psb_c_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_c_coo_clean_negidx(a,info) - import + import class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_clean_negidx @@ -1655,11 +1756,11 @@ module psb_c_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) @@ -1668,34 +1769,34 @@ module psb_c_base_mat_mod end subroutine psb_c_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner - + ! - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_ipk_), intent(in) :: m,n class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_c_coo_allocate_mnnz end interface - + !> \memberof psb_c_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_c_coo_mold(a,b,info) - import + interface + subroutine psb_c_coo_mold(a,b,info) + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_c_coo_sparse_mat @@ -1710,17 +1811,17 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_c_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_c_coo_sparse_mat @@ -1729,16 +1830,16 @@ module psb_c_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_c_coo_get_nz_row(idx,a) result(res) - import + import class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res end function psb_c_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -1750,12 +1851,12 @@ module psb_c_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) @@ -1764,162 +1865,162 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_c_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_c_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_c_fix_coo(a,info,idir) - import + interface + subroutine psb_c_fix_coo(a,info,idir) + import class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_c_fix_coo end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo - interface - subroutine psb_c_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_c_cp_coo_to_coo(a,b,info) + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo - interface - subroutine psb_c_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_c_cp_coo_from_coo(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_from_coo end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo - interface - subroutine psb_c_cp_coo_to_lcoo(a,b,info) - import + interface + subroutine psb_c_cp_coo_to_lcoo(a,b,info) + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_to_lcoo end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo - interface - subroutine psb_c_cp_coo_from_lcoo(a,b,info) - import + interface + subroutine psb_c_cp_coo_from_lcoo(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_from_lcoo end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo - !! - interface - subroutine psb_c_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_c_cp_coo_to_fmt(a,b,info) + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_fmt - !! - interface - subroutine psb_c_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_c_cp_coo_from_fmt(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_to_coo - interface - subroutine psb_c_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_c_mv_coo_to_coo(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo - interface - subroutine psb_c_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_c_mv_coo_from_coo(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_to_fmt - interface - subroutine psb_c_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_c_mv_coo_to_fmt(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt - interface - subroutine psb_c_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_c_mv_coo_from_fmt(a,b,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_c_coo_cp_from(a,b) - import + import class(psb_c_coo_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat), intent(in) :: b end subroutine psb_c_coo_cp_from end interface - - interface + + interface subroutine psb_c_coo_mv_from(a,b) - import + import class(psb_c_coo_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat), intent(inout) :: b end subroutine psb_c_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_c_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -1936,9 +2037,9 @@ module psb_c_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1946,14 +2047,14 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_csput_a end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1965,14 +2066,14 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_coo_csgetptn end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csgetrow - interface + interface subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1985,13 +2086,13 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_coo_csgetrow end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssv - interface - subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1999,12 +2100,12 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_coo_cssv end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssm - interface - subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -2012,13 +2113,13 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_coo_cssm end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csmv - interface - subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -2027,12 +2128,12 @@ module psb_c_base_mat_mod end subroutine psb_c_coo_csmv end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csmm - interface - subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -2040,121 +2141,173 @@ module psb_c_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_coo_csmm end interface - - - !> + + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_maxval - interface + interface function psb_c_coo_maxval(a) result(res) - import + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_coo_maxval end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csnmi - interface + interface function psb_c_coo_csnmi(a) result(res) - import + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_coo_csnmi end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csnm1 - interface + interface function psb_c_coo_csnm1(a) result(res) - import + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_coo_csnm1 end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_rowsum - interface - subroutine psb_c_coo_rowsum(d,a) - import + interface + subroutine psb_c_coo_rowsum(d,a) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_rowsum end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_arwsum - interface - subroutine psb_c_coo_arwsum(d,a) - import + interface + subroutine psb_c_coo_arwsum(d,a) + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_arwsum end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_colsum - interface - subroutine psb_c_coo_colsum(d,a) - import + interface + subroutine psb_c_coo_colsum(d,a) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_colsum end interface - !> + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_aclsum - interface - subroutine psb_c_coo_aclsum(d,a) - import + interface + subroutine psb_c_coo_aclsum(d,a) + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_aclsum end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_get_diag - interface - subroutine psb_c_coo_get_diag(a,d,info) - import + interface + subroutine psb_c_coo_get_diag(a,d,info) + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_get_diag end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scal - interface - subroutine psb_c_coo_scal(d,a,info,side) - import + interface + subroutine psb_c_coo_scal(d,a,info,side) + import class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_c_coo_scal end interface - - !> + + !> !! \memberof psb_c_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scals interface - subroutine psb_c_coo_scals(d,a,info) - import + subroutine psb_c_coo_scals(d,a,info) + import class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_scals end interface - + !> + !! \memberof psb_c_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_scalplusidentity + interface + subroutine psb_c_coo_scalplusidentity(d,a,info) + import + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_coo_scalplusidentity + end interface + ! + !! \memberof psb_c_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_spaxpby + interface + subroutine psb_c_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_coo_spaxpby + end interface + + ! + !! \memberof psb_c_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_cmpval + interface + function psb_c_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_c_coo_cmpval + end interface + + ! + !! \memberof psb_c_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_cmpmat + interface + function psb_c_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_c_coo_cmpmat + end interface + ! == ================= ! ! BASE interfaces @@ -2163,14 +2316,14 @@ module psb_c_base_mat_mod !> Function csput: !! \memberof psb_lc_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -2183,33 +2336,33 @@ module psb_c_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_csput_a end interface - - interface - subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2217,43 +2370,43 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_lc_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_lc_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -2266,33 +2419,33 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_lc_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_lc_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_lpk_), intent(in) :: imin,imax @@ -2303,34 +2456,34 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_lc_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_lc_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -2351,27 +2504,27 @@ module psb_c_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lc_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -2380,13 +2533,13 @@ module psb_c_base_mat_mod class(psb_lc_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_lc_base_tril end interface - + ! !> Function triu: !! \memberof psb_lc_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -2395,27 +2548,27 @@ module psb_c_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lc_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -2424,27 +2577,27 @@ module psb_c_base_mat_mod class(psb_lc_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_lc_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_lc_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_lc_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_lc_base_get_diag(a,d,info) + import class(psb_lc_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_lc_base_sparse_mat @@ -2454,10 +2607,10 @@ module psb_c_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mold(a,b,info) - import + ! + interface + subroutine psb_lc_base_mold(a,b,info) + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2469,21 +2622,21 @@ module psb_c_base_mat_mod !> Function clone: !! \memberof psb_lc_base_sparse_mat !! \brief Allocate and clone a class(psb_lc_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_lc_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_clone end interface @@ -2493,18 +2646,18 @@ module psb_c_base_mat_mod !> Function make_nonunit: !! \memberof psb_lc_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_lc_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a end subroutine psb_lc_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_lc_base_sparse_mat @@ -2512,16 +2665,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_to_coo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_lc_base_sparse_mat @@ -2529,16 +2682,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_from_coo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2547,16 +2700,16 @@ module psb_c_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_to_fmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2565,16 +2718,16 @@ module psb_c_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_from_fmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_lc_base_sparse_mat @@ -2582,16 +2735,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_to_coo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_lc_base_sparse_mat @@ -2599,16 +2752,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_from_coo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2617,16 +2770,16 @@ module psb_c_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_to_fmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2635,17 +2788,17 @@ module psb_c_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_from_fmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_from_fmt end interface - + ! !> Function cp_to_coo: !! \memberof psb_lc_base_sparse_mat @@ -2653,16 +2806,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_to_icoo(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_to_icoo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_to_icoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_lc_base_sparse_mat @@ -2670,16 +2823,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_from_icoo(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_from_icoo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_from_icoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2688,16 +2841,16 @@ module psb_c_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_to_ifmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_to_ifmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2706,16 +2859,16 @@ module psb_c_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_cp_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_cp_from_ifmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_cp_from_ifmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_lc_base_sparse_mat @@ -2723,16 +2876,16 @@ module psb_c_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_to_icoo(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_to_icoo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_to_icoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_lc_base_sparse_mat @@ -2740,16 +2893,16 @@ module psb_c_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_from_icoo(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_from_icoo(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_from_icoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2758,16 +2911,16 @@ module psb_c_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_to_ifmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_mv_to_ifmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_lc_base_sparse_mat @@ -2776,10 +2929,10 @@ module psb_c_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lc_base_mv_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_lc_base_mv_from_ifmt(a,b,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2789,111 +2942,150 @@ module psb_c_base_mat_mod ! - !> + !> !! \memberof psb_lc_base_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros ! interface subroutine psb_lc_base_clean_zeros(a, info) - import + import class(psb_lc_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_clean_zeros end interface - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_maxval - interface + interface function psb_lc_coo_maxval(a) result(res) - import + import class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_coo_maxval end interface - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_csnmi - interface + interface function psb_lc_coo_csnmi(a) result(res) - import + import class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_coo_csnmi end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_csnm1 - interface + interface function psb_lc_coo_csnm1(a) result(res) - import + import class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_coo_csnm1 end interface - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_rowsum - interface - subroutine psb_lc_coo_rowsum(d,a) - import + interface + subroutine psb_lc_coo_rowsum(d,a) + import class(psb_lc_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_coo_rowsum end interface - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_arwsum - interface - subroutine psb_lc_coo_arwsum(d,a) - import + interface + subroutine psb_lc_coo_arwsum(d,a) + import class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_coo_arwsum end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_colsum - interface - subroutine psb_lc_coo_colsum(d,a) - import + interface + subroutine psb_lc_coo_colsum(d,a) + import class(psb_lc_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_coo_colsum end interface - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_aclsum - interface - subroutine psb_lc_coo_aclsum(d,a) - import + interface + subroutine psb_lc_coo_aclsum(d,a) + import class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_coo_aclsum end interface - + ! !> Function base_scals: !! \memberof psb_lc_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_lc_base_scals(d,a,info) - import + interface + subroutine psb_lc_base_scals(d,a,info) + import class(psb_lc_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_base_scals end interface - + + ! + !> Function base_scalsplusidentity: + !! \memberof psb_lc_base_sparse_mat + !! \brief Scale a matrix by a single scalar value and adds identity + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_lc_base_scalplusidentity(d,a,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_scalplusidentity + end interface + ! + !> Function base_spaxpby: + !! \memberof psb_lc_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_lc_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_spaxpby + end interface + + ! !> Function base_scal: !! \memberof psb_lc_base_sparse_mat @@ -2903,40 +3095,86 @@ module psb_c_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_lc_base_scal(d,a,info,side) - import + interface + subroutine psb_lc_base_scal(d,a,info,side) + import class(psb_lc_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_lc_base_scal end interface - + + ! + !> Function base_cmpval: + !! \memberof psb_lc_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_lc_base_cmpval(a,val,tol,info) result(res) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lc_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_lc_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_lc_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lc_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_lc_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_lc_base_maxval(a) result(res) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_lc_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_lc_base_csnmi(a) result(res) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_base_csnmi @@ -2947,11 +3185,11 @@ module psb_c_base_mat_mod !> Function base_csnmi: !! \memberof psb_lc_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_lc_base_csnm1(a) result(res) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_base_csnm1 @@ -2963,11 +3201,11 @@ module psb_c_base_mat_mod !! \memberof psb_lc_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_lc_base_rowsum(d,a) - import + interface + subroutine psb_lc_base_rowsum(d,a) + import class(psb_lc_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_base_rowsum @@ -2978,26 +3216,26 @@ module psb_c_base_mat_mod !! \memberof psb_lc_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_lc_base_arwsum(d,a) - import + !! + interface + subroutine psb_lc_base_arwsum(d,a) + import class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_lc_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_lc_base_colsum(d,a) - import + interface + subroutine psb_lc_base_colsum(d,a) + import class(psb_lc_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_base_colsum @@ -3008,76 +3246,76 @@ module psb_c_base_mat_mod !! \memberof psb_lc_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_lc_base_aclsum(d,a) - import + !! + interface + subroutine psb_lc_base_aclsum(d,a) + import class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_base_aclsum end interface - + ! !> Function transp: !! \memberof psb_lc_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_lc_base_transp_2mat(a,b) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_lc_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_lc_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_lc_base_transc_2mat(a,b) - import + import class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_lc_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_lc_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_lc_base_transp_1mat(a) - import + import class(psb_lc_base_sparse_mat), intent(inout) :: a end subroutine psb_lc_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_lc_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_lc_base_transc_1mat(a) - import + import class(psb_lc_base_sparse_mat), intent(inout) :: a end subroutine psb_lc_base_transc_1mat end interface - + ! == =============== ! ! COO interfaces @@ -3085,82 +3323,82 @@ module psb_c_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_lc_coo_reallocate_nz(nz,a) - import + subroutine psb_lc_coo_reallocate_nz(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_lc_coo_sparse_mat), intent(inout) :: a end subroutine psb_lc_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_lc_coo_sparse_mat ! interface - subroutine psb_lc_coo_ensure_size(nz,a) - import + subroutine psb_lc_coo_ensure_size(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_lc_coo_sparse_mat), intent(inout) :: a end subroutine psb_lc_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_lc_coo_reinit(a,clear) - import - class(psb_lc_coo_sparse_mat), intent(inout) :: a + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lc_coo_reinit end interface ! - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_lc_coo_trim(a) - import + import class(psb_lc_coo_sparse_mat), intent(inout) :: a end subroutine psb_lc_coo_trim end interface ! - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros ! interface subroutine psb_lc_coo_clean_zeros(a,info) - import + import class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_coo_clean_zeros end interface - + ! - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_lc_coo_clean_negidx(a,info) - import + import class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_coo_clean_negidx end interface -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) ! !> Funtion: coo_clean_negidx_inner !! \brief Take out any entries with negative row or column index @@ -3171,11 +3409,11 @@ module psb_c_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) @@ -3183,34 +3421,34 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner -#endif +#endif ! - !> + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_lpk_), intent(in) :: m,n class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_lc_coo_allocate_mnnz end interface - + !> \memberof psb_lc_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lc_coo_mold(a,b,info) - import + interface + subroutine psb_lc_coo_mold(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_lc_coo_sparse_mat @@ -3225,17 +3463,17 @@ module psb_c_base_mat_mod ! interface subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lc_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_lc_coo_sparse_mat @@ -3244,16 +3482,16 @@ module psb_c_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_lc_coo_get_nz_row(idx,a) result(res) - import + import class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res end function psb_lc_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -3265,12 +3503,12 @@ module psb_c_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_lpk_), intent(in) :: nr,nc,nzin integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -3280,164 +3518,164 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_lc_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_lc_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_lc_fix_coo(a,info,idir) - import + interface + subroutine psb_lc_fix_coo(a,info,idir) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_lc_fix_coo end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo - interface - subroutine psb_lc_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_lc_cp_coo_to_coo(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo - interface - subroutine psb_lc_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_lc_cp_coo_from_coo(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_coo_from_coo end interface - - - !> + + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo - interface - subroutine psb_lc_cp_coo_to_icoo(a,b,info) - import + interface + subroutine psb_lc_cp_coo_to_icoo(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_coo_to_icoo end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo - interface - subroutine psb_lc_cp_coo_from_icoo(a,b,info) - import + interface + subroutine psb_lc_cp_coo_from_icoo(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_coo_from_icoo end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo - !! - interface - subroutine psb_lc_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_lc_cp_coo_to_fmt(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt - !! - interface - subroutine psb_lc_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_lc_cp_coo_from_fmt(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo - interface - subroutine psb_lc_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_lc_mv_coo_to_coo(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo - interface - subroutine psb_lc_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_lc_mv_coo_from_coo(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt - interface - subroutine psb_lc_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_lc_mv_coo_to_fmt(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt - interface - subroutine psb_lc_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_lc_mv_coo_from_fmt(a,b,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_lc_coo_cp_from(a,b) - import + import class(psb_lc_coo_sparse_mat), intent(inout) :: a type(psb_lc_coo_sparse_mat), intent(in) :: b end subroutine psb_lc_coo_cp_from end interface - - interface + + interface subroutine psb_lc_coo_mv_from(a,b) - import + import class(psb_lc_coo_sparse_mat), intent(inout) :: a type(psb_lc_coo_sparse_mat), intent(inout) :: b end subroutine psb_lc_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_lc_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -3454,9 +3692,9 @@ module psb_c_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& @@ -3464,14 +3702,14 @@ module psb_c_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_coo_csput_a end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3483,14 +3721,14 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_coo_csgetptn end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow - interface + interface subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3503,39 +3741,39 @@ module psb_c_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_coo_csgetrow end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag - interface - subroutine psb_lc_coo_get_diag(a,d,info) - import + interface + subroutine psb_lc_coo_get_diag(a,d,info) + import class(psb_lc_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_coo_get_diag end interface - - - !> + + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scal - interface - subroutine psb_lc_coo_scal(d,a,info,side) - import + interface + subroutine psb_lc_coo_scal(d,a,info,side) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_lc_coo_scal end interface - - !> + + !> !! \memberof psb_lc_coo_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scals interface - subroutine psb_lc_coo_scals(d,a,info) - import + subroutine psb_lc_coo_scals(d,a,info) + import class(psb_lc_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3543,11 +3781,64 @@ module psb_c_base_mat_mod end interface public :: psb_c_get_print_frmt, psb_lc_get_print_frmt - + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scalplusidentity + interface + subroutine psb_lc_coo_scalplusidentity(d,a,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_scalplusidentity + end interface + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_spaxpby + interface + subroutine psb_lc_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_spaxpby + end interface + + ! + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cmpval + interface + function psb_lc_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lc_coo_cmpval + end interface + + ! + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cmpmat + interface + function psb_lc_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lc_coo_cmpmat + end interface + contains - + function psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_ipk_), intent(in) :: nr, nc, nz @@ -3562,17 +3853,17 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_c_get_print_frmt - + function psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_lpk_), intent(in) :: nr, nc, nz @@ -3587,109 +3878,109 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_lc_get_print_frmt - - + + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function c_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function c_coo_sizeof - - + + function c_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function c_coo_get_fmt - - + + function c_coo_get_size(a) result(res) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function c_coo_get_size - - + + function c_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%nnz end function c_coo_get_nzeros - + function c_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function c_coo_is_by_rows - + function c_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function c_coo_is_by_cols - + function c_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function c_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3697,52 +3988,52 @@ contains ! ! ! == ================================== - + subroutine c_coo_set_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine c_coo_set_nzeros - + function c_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_c_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function c_coo_get_sort_status - + subroutine c_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_c_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine c_coo_set_sort_status - - + + subroutine c_coo_set_by_rows(a) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine c_coo_set_by_rows - - + + subroutine c_coo_set_by_cols(a) - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine c_coo_set_by_cols - + ! == ================================== ! ! @@ -3754,12 +4045,12 @@ contains ! ! ! == ================================== - - subroutine c_coo_free(a) - implicit none - + + subroutine c_coo_free(a) + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -3768,13 +4059,13 @@ contains call a%set_ncols(0_psb_ipk_) call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine c_coo_free - - - + + + ! == ================================== ! ! @@ -3788,132 +4079,132 @@ contains ! ! == ================================== subroutine c_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a - - integer(psb_ipk_), allocatable :: itemp(:) + + integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_c_base_sparse_mat%psb_base_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine c_coo_transp_1mat - + subroutine c_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_c_is_complex_) a%val(:) = conjg(a%val(:)) end subroutine c_coo_transc_1mat - + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function lc_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_lp res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function lc_coo_sizeof - - + + function lc_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function lc_coo_get_fmt - - + + function lc_coo_get_size(a) result(res) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function lc_coo_get_size - - + + function lc_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%nnz end function lc_coo_get_nzeros - + function lc_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function lc_coo_is_by_rows - + function lc_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function lc_coo_is_by_cols - + function lc_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function lc_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3921,63 +4212,63 @@ contains ! ! ! == ================================== - + subroutine lc_coo_iset_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_lc_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine lc_coo_iset_nzeros #if defined(IPK4) && defined(LPK8) subroutine lc_coo_lset_nzeros(nz,a) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lc_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine lc_coo_lset_nzeros #endif - + function lc_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_lc_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function lc_coo_get_sort_status - + subroutine lc_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_lc_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine lc_coo_set_sort_status - - + + subroutine lc_coo_set_by_rows(a) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine lc_coo_set_by_rows - - + + subroutine lc_coo_set_by_cols(a) - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine lc_coo_set_by_cols - + ! == ================================== ! ! @@ -3989,12 +4280,12 @@ contains ! ! ! == ================================== - - subroutine lc_coo_free(a) - implicit none - + + subroutine lc_coo_free(a) + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -4003,13 +4294,13 @@ contains call a%set_ncols(0_psb_lpk_) call a%set_nzeros(0_psb_lpk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine lc_coo_free - - - + + + ! == ================================== ! ! @@ -4023,40 +4314,37 @@ contains ! ! == ================================== subroutine lc_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a - - integer(psb_lpk_), allocatable :: itemp(:) + + integer(psb_lpk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_lc_base_sparse_mat%psb_lbase_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine lc_coo_transp_1mat - + subroutine lc_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_lc_is_complex_) a%val(:) = conjg(a%val(:)) end subroutine lc_coo_transc_1mat end module psb_c_base_mat_mod - - - diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index 59f9816d3..116b2a8d1 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_c_base_vect_mod ! ! This module contains the definition of the psb_c_base_vect type which ! is a container for dense vectors. -! This is encapsulated instead of being just a simple array to allow for +! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran ! side. It is also meant to be encapsulated in an outer type, to allow @@ -43,7 +43,7 @@ ! ! module psb_c_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_c_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_c_base_vect_type - !! The psb_c_base_vect_type + !! The psb_c_base_vect_type !! defines a middle level complex(psb_spk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow @@ -61,9 +61,9 @@ module psb_c_base_vect_mod !! sparse matrix types. !! type psb_c_base_vect_type - !> Values. + !> Values. complex(psb_spk_), allocatable :: v(:) - complex(psb_spk_), allocatable :: combuf(:) + complex(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_c_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => c_base_ins_a procedure, pass(x) :: ins_v => c_base_ins_v @@ -93,7 +93,7 @@ module psb_c_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => c_base_sync procedure, pass(x) :: is_host => c_base_is_host @@ -130,7 +130,7 @@ module psb_c_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => c_base_gthab procedure, pass(x) :: gthzv => c_base_gthzv @@ -151,7 +151,9 @@ module psb_c_base_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => c_base_axpby_v procedure, pass(y) :: axpby_a => c_base_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => c_base_axpby_v2 + procedure, pass(z) :: axpby_a2 => c_base_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 ! ! Vector by vector multiplication. Need all variants ! to handle multiple requirements from preconditioners @@ -162,7 +164,24 @@ module psb_c_base_vect_mod procedure, pass(z) :: mlt_v_2 => c_base_mlt_v_2 procedure, pass(z) :: mlt_va => c_base_mlt_va procedure, pass(z) :: mlt_av => c_base_mlt_av - generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va + generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, & + mlt_va + ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => c_base_div_v + procedure, pass(x) :: div_v_check => c_base_div_v_check + procedure, pass(z) :: div_v2 => c_base_div_v2 + procedure, pass(z) :: div_v2_check => c_base_div_v2_check + procedure, pass(z) :: div_a2 => c_base_div_a2 + procedure, pass(z) :: div_a2_check => c_base_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => c_base_inv_v + procedure, pass(y) :: inv_v_check => c_base_inv_v_check + procedure, pass(y) :: inv_a2 => c_base_inv_a2 + procedure, pass(y) :: inv_a2_check => c_base_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check ! ! Scaling and norms ! @@ -174,6 +193,22 @@ module psb_c_base_vect_mod procedure, pass(x) :: amax => c_base_amax procedure, pass(x) :: asum => c_base_asum + ! + ! Comparison and mask operation + ! + procedure, pass(z) :: acmp_a2 => c_base_acmp_a2 + procedure, pass(z) :: acmp_v2 => c_base_acmp_v2 + generic, public :: acmp => acmp_a2,acmp_v2 + ! + ! Add constant value to all entry of a vector + ! + procedure, pass(z) :: addconst_a2 => c_base_addconst_a2 + procedure, pass(z) :: addconst_v2 => c_base_addconst_v2 + generic, public :: addconst => addconst_a2,addconst_v2 + + + + end type psb_c_base_vect_type public :: psb_c_base_vect @@ -183,11 +218,11 @@ module psb_c_base_vect_mod end interface psb_c_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +235,11 @@ contains this%v = x call this%asb(size(x,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +249,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +261,20 @@ contains !! subroutine c_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: this(:) class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine c_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +282,11 @@ contains !> Function bld_mn: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine c_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +295,15 @@ contains call x%asb(n,info) end subroutine c_base_bld_mn - + !> Function bld_en: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine c_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +312,24 @@ contains call x%asb(n,info) end subroutine c_base_bld_en - + !> Function base_all: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine c_base_all(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_base_vect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(n,x%v,info) - + end subroutine c_base_all !> Function base_mold: @@ -306,11 +341,11 @@ contains subroutine c_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x class(psb_c_base_vect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_c_base_vect_type :: y, stat=info) end subroutine c_base_mold @@ -320,21 +355,21 @@ contains ! !> Function base_ins: !! \memberof psb_c_base_vect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -344,7 +379,7 @@ contains ! subroutine c_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +389,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -376,7 +411,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +429,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +438,7 @@ contains subroutine c_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +448,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() call x%ins(n,irl%v,val%v,dupl,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +471,14 @@ contains ! subroutine c_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=czero call x%set_host() end subroutine c_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +487,20 @@ contains !> Function base_asb: !! \memberof psb_c_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine c_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +517,20 @@ contains !> Function base_asb: !! \memberof psb_c_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine c_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +543,39 @@ contains !> Function base_free: !! \memberof psb_c_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine c_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if (info == 0) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine c_base_free - + ! !> Function base_free_buffer: !! \memberof psb_c_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine c_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +590,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine c_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +610,13 @@ contains !> Function base_free_comid: !! \memberof psb_c_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine c_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +628,77 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_c_base_vect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine c_base_sync(x) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x - + end subroutine c_base_sync ! !> Function base_set_host: !! \memberof psb_c_base_vect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine c_base_set_host(x) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x - + end subroutine c_base_set_host ! !> Function base_set_dev: !! \memberof psb_c_base_vect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine c_base_set_dev(x) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x - + end subroutine c_base_set_dev ! !> Function base_set_sync: !! \memberof psb_c_base_vect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine c_base_set_sync(x) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x - + end subroutine c_base_set_sync ! !> Function base_is_dev: !! \memberof psb_c_base_vect_type !! \brief Is vector on external device . - !! + !! ! function c_base_is_dev(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x logical :: res - + res = .false. end function c_base_is_dev - + ! !> Function base_is_host !! \memberof psb_c_base_vect_type !! \brief Is vector on standard memory . - !! + !! ! function c_base_is_host(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +709,10 @@ contains !> Function base_is_sync !! \memberof psb_c_base_vect_type !! \brief Is vector on sync . - !! + !! ! function c_base_is_sync(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +721,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_c_base_vect_type !! \brief Number of entries - !! + !! ! function c_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +743,13 @@ contains !> Function base_get_sizeof !! \memberof psb_c_base_vect_type !! \brief Size in bytes - !! + !! ! function c_base_sizeof(x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(in) :: x integer(psb_epk_) :: res - + ! Force 8-byte integers. res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() @@ -724,14 +759,14 @@ contains !> Function base_get_fmt !! \memberof psb_c_base_vect_type !! \brief Format - !! + !! ! function c_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function c_base_get_fmt - + ! ! @@ -740,7 +775,7 @@ contains !! \memberof psb_c_base_vect_type !! \brief Extract a copy of the contents !! - ! + ! function c_base_get_vect(x,n) result(res) class(psb_c_base_vect_type), intent(inout) :: x complex(psb_spk_), allocatable :: res(:) @@ -748,21 +783,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + if (.not.allocated(x%v)) return if (.not.x%is_host()) call x%sync() isz = x%get_nrows() if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function c_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +806,18 @@ contains !! \param val The value to set !! subroutine c_base_set_scal(x,val,first,last) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_ first_=1 last_=size(x%v) if (present(first)) first_ = max(1,first) if (present(last)) last_ = min(last,last_) - + if (x%is_dev()) call x%sync() x%v(first_:last_) = val call x%set_host() @@ -794,14 +829,14 @@ contains !> Function base_set_vect !! \memberof psb_c_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine c_base_set_vect(x,val,first,last) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +844,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +864,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine c_base_absval1(x) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +876,21 @@ contains end subroutine c_base_absval1 subroutine c_base_absval2(x,y) - implicit none - class(psb_c_base_vect_type), intent(inout) :: x + implicit none + class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: y integer(psb_ipk_) :: info if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) call y%absval() end if - + end subroutine c_base_absval2 ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_c_base_vect_type @@ -864,12 +899,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function c_base_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_spk_) :: res complex(psb_spk_), external :: cdotc - + res = czero ! ! Note: this is the base implementation. @@ -898,19 +933,19 @@ contains !! \param y(:) The array to be multiplied by !! function c_base_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n complex(psb_spk_) :: res complex(psb_spk_), external :: cdotc - + res = cdotc(n,y,1,x%v,1) end function c_base_dot_a - + ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +960,13 @@ contains !! subroutine c_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: y complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (x%is_dev()) call x%sync() call y%axpby(m,alpha,x%v,beta,info) @@ -939,7 +974,39 @@ contains end subroutine c_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_c_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar alpha + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + subroutine c_base_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine c_base_axpby_v2 + + ! + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +1020,50 @@ contains !! subroutine c_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent(in) :: x(:) class(psb_c_base_vect_type), intent(inout) :: y complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (y%is_dev()) call y%sync() call psb_geaxpby(m,alpha,x,beta,y%v,info) call y%set_host() - + end subroutine c_base_axpby_a - + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_c_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + subroutine c_base_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine c_base_axpby_a2 + + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +1081,10 @@ contains !! subroutine c_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1102,7 @@ contains !! subroutine c_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:) class(psb_c_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1111,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1132,7 @@ contains !! subroutine c_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) complex(psb_spk_), intent(in) :: x(:) @@ -1043,58 +1140,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (z%is_dev()) call z%sync() n = min(size(z%v), size(x), size(y)) - if (alpha == czero) then - if (beta == cone) then - return + if (alpha == czero) then + if (beta == cone) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == cone) then - if (beta == czero) then - do i=1, n + if (alpha == cone) then + if (beta == czero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == cone) then - do i=1, n + else if (beta == cone) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + y(i)*x(i) end do end if - else if (alpha == -cone) then - if (beta == czero) then - do i=1, n + else if (alpha == -cone) then + if (beta == czero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == cone) then - do i=1, n + else if (beta == cone) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == czero) then - do i=1, n + if (beta == czero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == cone) then - do i=1, n + else if (beta == cone) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1215,12 @@ contains subroutine c_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: y class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1230,7 @@ contains if (x%is_dev()) call x%sync() if (.not.psb_c_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1245,12 @@ contains subroutine c_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: x(:) class(psb_c_base_vect_type), intent(inout) :: y class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1261,12 @@ contains subroutine c_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1274,318 @@ contains call z%mlt(alpha,y,x,beta,info) end subroutine c_base_mlt_va + ! + !> Function base_div_v + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine c_base_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info) + + + end subroutine c_base_div_v + ! + !> Function base_div_v2 + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine c_base_div_v2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + end subroutine c_base_div_v2 + ! + !> Function base_div_v_check + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine c_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine c_base_div_v_check + ! + !> Function base_div_v2_check + !! \memberof psb_c_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine c_base_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + + end subroutine c_base_div_v2_check + ! + !> Function base_div_a2 + !! \memberof psb_c_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + subroutine c_base_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine c_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine c_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: z + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call c_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + + end subroutine c_base_div_a2_check + ! + !> Function base_inv_v + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + subroutine c_base_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine c_base_inv_v + ! + !> Function base_inv_v_check + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + subroutine c_base_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + + end subroutine c_base_inv_v_check + ! + !> Function base_inv_a2 + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + subroutine c_base_inv_a2(x, y, info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + y%v(i) = 1_psb_spk_/x(i) + end do + + end subroutine c_base_inv_a2 + ! + !> Function base_inv_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + subroutine c_base_inv_a2_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: y + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call c_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_spk_/x(i) + else + info = 1 + y%v(i) = 0_psb_spk_ + end if + end do + end if + + + end subroutine c_base_inv_a2_check ! - ! Simple scaling + !> Function base_inv_a2_check + !! \memberof psb_c_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine c_base_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_spk_ + else + z%v(i) = 0_psb_spk_ + end if + end do + info = 0 + + end subroutine c_base_acmp_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_c_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine c_base_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine c_base_acmp_v2 + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_c_base_vect_type @@ -1189,17 +1594,17 @@ contains !! subroutine c_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine c_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,50 +1613,51 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function c_base_nrm2(n,x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res real(psb_spk_), external :: scnrm2 - + if (x%is_dev()) call x%sync() res = scnrm2(n,x%v,1) end function c_base_nrm2 - + ! !> Function base_amax !! \memberof psb_c_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function c_base_amax(n,x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) end function c_base_amax + ! !> Function base_asum !! \memberof psb_c_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function c_base_asum(n,x) result(res) - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function c_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1672,18 @@ contains !! \param beta subroutine c_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: alpha, beta, y(:) class(psb_c_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,alpha,x%v,beta,y) end subroutine c_base_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_c_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1286,28 +1692,28 @@ contains !! \param idx(:) indices subroutine c_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: y(:) class(psb_c_base_vect_type) :: x - + if (idx%is_dev()) call idx%sync() call x%gth(n,idx%v(i:),y) end subroutine c_base_gthzv_x ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine c_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_c_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1726,22 @@ contains !> Function base_device_wait: !! \memberof psb_c_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine c_base_device_wait() - implicit none - + implicit none + end subroutine c_base_device_wait function c_base_use_buffer() result(res) logical :: res - + res = .true. end function c_base_use_buffer subroutine c_base_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1751,7 @@ contains subroutine c_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1762,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_c_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1771,20 @@ contains !! \param idx(:) indices subroutine c_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: y(:) class(psb_c_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,x%v,y) end subroutine c_base_gthzv ! - ! Scatter: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_c_base_vect_type @@ -1387,14 +1793,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine c_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:) class(psb_c_base_vect_type) :: y - + if (y%is_dev()) call y%sync() call psi_sct(n,idx,x,beta,y%v) call y%set_host() @@ -1403,12 +1809,12 @@ contains subroutine c_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: beta, x(:) class(psb_c_base_vect_type) :: y - + if (idx%is_dev()) call idx%sync() call y%sct(n,idx%v(i:),x,beta) call y%set_host() @@ -1417,14 +1823,14 @@ contains subroutine c_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: beta class(psb_c_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1435,6 +1841,55 @@ contains end subroutine c_base_sctb_buf + + ! + !> Function _base_addconst_a2 + !! \memberof psb_c_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine c_base_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: b + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + z%v(i) = x(i) + b + end do + info = 0 + + end subroutine c_base_addconst_a2 + ! + !> Function _base_addconst_v2 + !! \memberof psb_c_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine c_base_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: b + class(psb_c_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine c_base_addconst_v2 end module psb_c_base_vect_mod @@ -1449,22 +1904,22 @@ module psb_c_base_multivect_mod use psb_c_base_vect_mod !> \namespace psb_base_mod \class psb_c_base_vect_type - !! The psb_c_base_vect_type + !! The psb_c_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private + private public :: psb_c_base_multivect, psb_c_base_multivect_type type psb_c_base_multivect_type - !> Values. + !> Values. complex(psb_spk_), allocatable :: v(:,:) - complex(psb_spk_), allocatable :: combuf(:) + complex(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +1933,7 @@ module psb_c_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => c_base_mlv_ins procedure, pass(x) :: zero => c_base_mlv_zero @@ -1489,7 +1944,7 @@ module psb_c_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => c_base_mlv_sync procedure, pass(x) :: is_host => c_base_mlv_is_host @@ -1562,7 +2017,7 @@ module psb_c_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => c_base_mlv_gthab procedure, pass(x) :: gthzv => c_base_mlv_gthzv @@ -1584,7 +2039,7 @@ module psb_c_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +2058,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +2085,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +2100,7 @@ contains !> Function bld_n: !! \memberof psb_c_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine c_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +2117,13 @@ contains !! \memberof psb_c_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine c_base_mlv_all(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +2141,7 @@ contains subroutine c_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x class(psb_c_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info @@ -1700,21 +2155,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_c_base_multivect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -1724,7 +2179,7 @@ contains ! subroutine c_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +2189,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -1756,7 +2211,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +2228,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +2243,7 @@ contains ! subroutine c_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=czero @@ -1804,7 +2259,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_c_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +2268,7 @@ contains subroutine c_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +2285,20 @@ contains !> Function base_mlv_free: !! \memberof psb_c_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine c_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine c_base_mlv_free @@ -1853,15 +2308,15 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_mlv_sync: !! \memberof psb_c_base_multivect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine c_base_mlv_sync(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_sync @@ -1870,10 +2325,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_c_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine c_base_mlv_set_host(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_set_host @@ -1882,10 +2337,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_c_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine c_base_mlv_set_dev(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_set_dev @@ -1894,10 +2349,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_c_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine c_base_mlv_set_sync(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x end subroutine c_base_mlv_set_sync @@ -1906,10 +2361,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_c_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function c_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +2375,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_c_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function c_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +2389,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_c_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function c_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +2401,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_c_base_multivect_type !! \brief Number of entries - !! + !! ! function c_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2420,7 @@ contains end function c_base_mlv_get_nrows function c_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2433,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_c_base_multivect_type !! \brief Size in bytesa - !! + !! ! function c_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2449,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_c_base_multivect_type !! \brief Format - !! + !! ! function c_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function c_base_mlv_get_fmt @@ -2010,18 +2465,18 @@ contains !! \memberof psb_c_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function c_base_mlv_get_vect(x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), allocatable :: res(:,:) integer(psb_ipk_) :: info,m,n m = x%get_nrows() n = x%get_ncols() - if (.not.allocated(x%v)) return + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2484,7 @@ contains end function c_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2493,7 @@ contains !! \param val The value to set !! subroutine c_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val @@ -2051,16 +2506,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_c_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine c_base_mlv_set_vect(x,val) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_) :: nr, nc integer(psb_ipk_) :: info - if (allocated(x%v)) then + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2527,8 @@ contains end subroutine c_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_c_base_multivect_type @@ -2082,7 +2537,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function c_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_spk_), allocatable :: res(:) @@ -2094,7 +2549,7 @@ contains ! ! Note: this is the base implementation. ! When we get here, we are sure that X is of - ! TYPE psb_c_base_mlv_vect (or its class does not care). + ! TYPE psb_c_base_mlv_vect (or its class does not care). ! If Y is not, throw the burden on it, implicitly ! calling dot_a ! @@ -2123,7 +2578,7 @@ contains !! \param y(:) The array to be multiplied by !! function c_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2596,7 @@ contains end function c_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2611,7 @@ contains !! subroutine c_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_c_base_multivect_type), intent(inout) :: x class(psb_c_base_multivect_type), intent(inout) :: y @@ -2180,7 +2635,7 @@ contains end subroutine c_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2649,7 @@ contains !! subroutine c_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent(in) :: x(:,:) class(psb_c_base_multivect_type), intent(inout) :: y @@ -2230,10 +2685,10 @@ contains !! subroutine c_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2698,10 @@ contains subroutine c_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_c_base_vect_type), intent(inout) :: x class(psb_c_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2718,7 @@ contains !! subroutine c_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:) class(psb_c_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2726,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2741,7 @@ contains !! subroutine c_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:,:) class(psb_c_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2768,7 @@ contains !! subroutine c_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:,:) complex(psb_spk_), intent(in) :: x(:,:) @@ -2321,38 +2776,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + info = 0 nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == czero) then - if (beta == cone) then - return + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == czero) then + if (beta == cone) then + return else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) end if else - if (alpha == cone) then - if (beta == czero) then + if (alpha == cone) then + if (beta == czero) then z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == cone) then + else if (beta == cone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) end if - else if (alpha == -cone) then - if (beta == czero) then + else if (alpha == -cone) then + if (beta == czero) then z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == cone) then + else if (beta == cone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) end if else - if (beta == czero) then + if (beta == czero) then z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == cone) then + else if (beta == cone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) end if end if @@ -2373,12 +2828,12 @@ contains subroutine c_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta class(psb_c_base_multivect_type), intent(inout) :: x class(psb_c_base_multivect_type), intent(inout) :: y class(psb_c_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +2844,7 @@ contains if (z%is_dev()) call z%sync() if (.not.psb_c_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +2859,39 @@ contains !!$ !!$ subroutine c_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_base_multivect_type), intent(inout) :: y !!$ class(psb_c_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,x,y%v,beta,info) !!$ !!$ end subroutine c_base_mlv_mlt_av !!$ !!$ subroutine c_base_mlv_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: y(:) !!$ class(psb_c_base_multivect_type), intent(inout) :: x !!$ class(psb_c_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,y,x,beta,info) !!$ !!$ end subroutine c_base_mlv_mlt_va !!$ !!$ ! - ! Simple scaling + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_c_base_multivect_type @@ -2445,7 +2900,7 @@ contains !! subroutine c_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha @@ -2462,7 +2917,7 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function c_base_mlv_nrm2(n,x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2484,7 +2939,7 @@ contains !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function c_base_mlv_amax(n,x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2505,7 +2960,7 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function c_base_mlv_asum(n,x) result(res) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2528,7 +2983,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine c_base_mlv_absval1(x) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +2995,13 @@ contains end subroutine c_base_mlv_absval1 subroutine c_base_mlv_absval2(x,y) - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x class(psb_c_base_multivect_type), intent(inout) :: y integer(psb_ipk_) :: info - + if (x%is_dev()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),cone,x,czero,info) call y%absval() end if @@ -2555,15 +3010,15 @@ contains function c_base_mlv_use_buffer() result(res) - implicit none + implicit none logical :: res - + res = .true. end function c_base_mlv_use_buffer subroutine c_base_mlv_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +3030,7 @@ contains subroutine c_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +3041,12 @@ contains subroutine c_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +3054,7 @@ contains subroutine c_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +3064,7 @@ contains subroutine c_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_c_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +3087,7 @@ contains !! \param beta subroutine c_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: alpha, beta, y(:) class(psb_c_base_multivect_type) :: x @@ -2648,7 +3103,7 @@ contains end subroutine c_base_mlv_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_c_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2657,7 +3112,7 @@ contains !! \param idx(:) indices subroutine c_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: y(:) @@ -2670,7 +3125,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_c_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2679,7 +3134,7 @@ contains !! \param idx(:) indices subroutine c_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: y(:) class(psb_c_base_multivect_type) :: x @@ -2696,7 +3151,7 @@ contains end subroutine c_base_mlv_gthzv ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_c_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2705,7 +3160,7 @@ contains !! \param idx(:) indices subroutine c_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: y(:,:) class(psb_c_base_multivect_type) :: x @@ -2722,17 +3177,17 @@ contains end subroutine c_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine c_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_c_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +3199,9 @@ contains end subroutine c_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_c_base_multivect_type @@ -2755,10 +3210,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine c_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:) class(psb_c_base_multivect_type) :: y @@ -2773,7 +3228,7 @@ contains subroutine c_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_spk_) :: beta, x(:,:) class(psb_c_base_multivect_type) :: y @@ -2788,7 +3243,7 @@ contains subroutine c_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex( psb_spk_) :: beta, x(:) @@ -2800,14 +3255,14 @@ contains subroutine c_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n class(psb_i_base_vect_type) :: idx complex(psb_spk_) :: beta class(psb_c_base_multivect_type) :: y integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +3271,18 @@ contains nc = y%get_ncols() call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) call y%set_host() - + end subroutine c_base_mlv_sctb_buf ! !> Function base_device_wait: !! \memberof psb_c_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine c_base_mlv_device_wait() - implicit none - + implicit none + end subroutine c_base_mlv_device_wait end module psb_c_base_multivect_mod - diff --git a/base/modules/serial/psb_c_csc_mat_mod.f90 b/base/modules/serial/psb_c_csc_mat_mod.f90 index 5a98200e8..bb06977b8 100644 --- a/base/modules/serial/psb_c_csc_mat_mod.f90 +++ b/base/modules/serial/psb_c_csc_mat_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_c_csc_mat_mod ! @@ -40,23 +40,23 @@ ! ! Please refere to psb_c_base_mat_mod for a detailed description ! of the various methods, and to psb_c_csc_impl for implementation details. -! +! module psb_c_csc_mat_mod use psb_c_base_mat_mod !> \namespace psb_base_mod \class psb_c_csc_sparse_mat !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat - !! + !! !! psb_c_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_c_base_sparse_mat) :: psb_c_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_ipk_), allocatable :: icp(:) !> Row indices. integer(psb_ipk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. complex(psb_spk_), allocatable :: val(:) contains @@ -107,16 +107,16 @@ module psb_c_csc_mat_mod !> \namespace psb_base_mod \class psb_c_csc_sparse_mat !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat - !! + !! !! psb_c_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_lc_base_sparse_mat) :: psb_lc_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_lpk_), allocatable :: icp(:) !> Row indices. integer(psb_lpk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. complex(psb_spk_), allocatable :: val(:) contains @@ -163,23 +163,23 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_c_csc_reallocate_nz(nz,a) + subroutine psb_c_csc_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_c_csc_sparse_mat), intent(inout) :: a end subroutine psb_c_csc_reallocate_nz end interface - + !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_c_csc_reinit(a,clear) import - class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_csc_reinit end interface - + !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -188,22 +188,22 @@ module psb_c_csc_mat_mod class(psb_c_csc_sparse_mat), intent(inout) :: a end subroutine psb_c_csc_trim end interface - + !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_c_csc_mold(a,b,info) + interface + subroutine psb_c_csc_mold(a,b,info) import class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csc_mold end interface - + !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -211,147 +211,147 @@ module psb_c_csc_mat_mod end subroutine psb_c_csc_allocate_mnnz end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_print interface subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_c_csc_print end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo - interface - subroutine psb_c_cp_csc_to_coo(a,b,info) + interface + subroutine psb_c_cp_csc_to_coo(a,b,info) import class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csc_to_coo end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo - interface - subroutine psb_c_cp_csc_from_coo(a,b,info) + interface + subroutine psb_c_cp_csc_from_coo(a,b,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csc_from_coo end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_to_fmt - interface - subroutine psb_c_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_c_cp_csc_to_fmt(a,b,info) import class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csc_to_fmt end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_fmt - interface - subroutine psb_c_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_c_cp_csc_from_fmt(a,b,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csc_from_fmt end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_to_coo - interface - subroutine psb_c_mv_csc_to_coo(a,b,info) + interface + subroutine psb_c_mv_csc_to_coo(a,b,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csc_to_coo end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo - interface - subroutine psb_c_mv_csc_from_coo(a,b,info) + interface + subroutine psb_c_mv_csc_from_coo(a,b,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csc_from_coo end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_to_fmt - interface - subroutine psb_c_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_c_mv_csc_to_fmt(a,b,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csc_to_fmt end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt - interface - subroutine psb_c_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_c_mv_csc_from_fmt(a,b,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_clean_zeros ! interface subroutine psb_c_csc_clean_zeros(a, info) - import + import class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csc_clean_zeros end interface - - + + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from - interface + interface subroutine psb_c_csc_cp_from(a,b) import class(psb_c_csc_sparse_mat), intent(inout) :: a type(psb_c_csc_sparse_mat), intent(in) :: b end subroutine psb_c_csc_cp_from end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from - interface + interface subroutine psb_c_csc_mv_from(a,b) import class(psb_c_csc_sparse_mat), intent(inout) :: a type(psb_c_csc_sparse_mat), intent(inout) :: b end subroutine psb_c_csc_mv_from end interface - - + + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csput_a - interface - subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -360,10 +360,10 @@ module psb_c_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csc_csput_a end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -378,10 +378,10 @@ module psb_c_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_csc_csgetptn end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csgetrow - interface + interface subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ @@ -400,7 +400,7 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csgetblk - interface + interface subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) import @@ -414,11 +414,11 @@ module psb_c_csc_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_csc_csgetblk end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssv - interface - subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -429,8 +429,8 @@ module psb_c_csc_mat_mod end interface !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssm - interface - subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -439,11 +439,11 @@ module psb_c_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_csc_cssm end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csmv - interface - subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -455,8 +455,8 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csmm - interface - subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -465,21 +465,21 @@ module psb_c_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_csc_csmm end interface - - + + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_maxval - interface + interface function psb_c_csc_maxval(a) result(res) import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csc_maxval end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csnm1 - interface + interface function psb_c_csc_csnm1(a) result(res) import class(psb_c_csc_sparse_mat), intent(in) :: a @@ -489,8 +489,8 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_rowsum - interface - subroutine psb_c_csc_rowsum(d,a) + interface + subroutine psb_c_csc_rowsum(d,a) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -499,18 +499,18 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_arwsum - interface - subroutine psb_c_csc_arwsum(d,a) + interface + subroutine psb_c_csc_arwsum(d,a) import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csc_arwsum end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_colsum - interface - subroutine psb_c_csc_colsum(d,a) + interface + subroutine psb_c_csc_colsum(d,a) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -519,29 +519,29 @@ module psb_c_csc_mat_mod !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_aclsum - interface - subroutine psb_c_csc_aclsum(d,a) + interface + subroutine psb_c_csc_aclsum(d,a) import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csc_aclsum end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_get_diag - interface - subroutine psb_c_csc_get_diag(a,d,info) + interface + subroutine psb_c_csc_get_diag(a,d,info) import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csc_get_diag end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scal - interface - subroutine psb_c_csc_scal(d,a,info,side) + interface + subroutine psb_c_csc_scal(d,a,info,side) import class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) @@ -549,42 +549,41 @@ module psb_c_csc_mat_mod character, intent(in), optional :: side end subroutine psb_c_csc_scal end interface - + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scals interface - subroutine psb_c_csc_scals(d,a,info) + subroutine psb_c_csc_scals(d,a,info) import class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csc_scals end interface - ! ! lc - ! + ! !> \memberof psb_lc_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_lc_csc_reallocate_nz(nz,a) + subroutine psb_lc_csc_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_lc_csc_sparse_mat), intent(inout) :: a end subroutine psb_lc_csc_reallocate_nz end interface - + !> \memberof psb_lc_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_lc_csc_reinit(a,clear) import - class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lc_csc_reinit end interface - + !> \memberof psb_lc_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -593,22 +592,22 @@ module psb_c_csc_mat_mod class(psb_lc_csc_sparse_mat), intent(inout) :: a end subroutine psb_lc_csc_trim end interface - + !> \memberof psb_lc_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lc_csc_mold(a,b,info) + interface + subroutine psb_lc_csc_mold(a,b,info) import class(psb_lc_csc_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csc_mold end interface - + !> \memberof psb_lc_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_lc_csc_sparse_mat), intent(inout) :: a @@ -616,146 +615,146 @@ module psb_c_csc_mat_mod end subroutine psb_lc_csc_allocate_mnnz end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_print interface subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lc_csc_print end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo - interface - subroutine psb_lc_cp_csc_to_coo(a,b,info) + interface + subroutine psb_lc_cp_csc_to_coo(a,b,info) import class(psb_lc_csc_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csc_to_coo end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo - interface - subroutine psb_lc_cp_csc_from_coo(a,b,info) + interface + subroutine psb_lc_cp_csc_from_coo(a,b,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csc_from_coo end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_fmt - interface - subroutine psb_lc_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_lc_cp_csc_to_fmt(a,b,info) import class(psb_lc_csc_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csc_to_fmt end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt - interface - subroutine psb_lc_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_lc_cp_csc_from_fmt(a,b,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csc_from_fmt end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo - interface - subroutine psb_lc_mv_csc_to_coo(a,b,info) + interface + subroutine psb_lc_mv_csc_to_coo(a,b,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csc_to_coo end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo - interface - subroutine psb_lc_mv_csc_from_coo(a,b,info) + interface + subroutine psb_lc_mv_csc_from_coo(a,b,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csc_from_coo end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt - interface - subroutine psb_lc_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_lc_mv_csc_to_fmt(a,b,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csc_to_fmt end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt - interface - subroutine psb_lc_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_lc_mv_csc_from_fmt(a,b,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros ! interface subroutine psb_lc_csc_clean_zeros(a, info) - import + import class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csc_clean_zeros end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from - interface + interface subroutine psb_lc_csc_cp_from(a,b) import class(psb_lc_csc_sparse_mat), intent(inout) :: a type(psb_lc_csc_sparse_mat), intent(in) :: b end subroutine psb_lc_csc_cp_from end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from - interface + interface subroutine psb_lc_csc_mv_from(a,b) import class(psb_lc_csc_sparse_mat), intent(inout) :: a type(psb_lc_csc_sparse_mat), intent(inout) :: b end subroutine psb_lc_csc_mv_from end interface - - + + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a - interface - subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -764,10 +763,10 @@ module psb_c_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csc_csput_a end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_lc_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -782,10 +781,10 @@ module psb_c_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csc_csgetptn end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow - interface + interface subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -804,7 +803,7 @@ module psb_c_csc_mat_mod !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_csgetblk - interface + interface subroutine psb_lc_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import @@ -818,31 +817,31 @@ module psb_c_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csc_csgetblk end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag - interface - subroutine psb_lc_csc_get_diag(a,d,info) + interface + subroutine psb_lc_csc_get_diag(a,d,info) import class(psb_lc_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csc_get_diag end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_maxval - interface + interface function psb_lc_csc_maxval(a) result(res) import class(psb_lc_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_csc_maxval end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_csnm1 - interface + interface function psb_lc_csc_csnm1(a) result(res) import class(psb_lc_csc_sparse_mat), intent(in) :: a @@ -852,8 +851,8 @@ module psb_c_csc_mat_mod !> \memberof psb_lc_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_rowsum - interface - subroutine psb_lc_csc_rowsum(d,a) + interface + subroutine psb_lc_csc_rowsum(d,a) import class(psb_lc_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -862,18 +861,18 @@ module psb_c_csc_mat_mod !> \memberof psb_lc_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_arwsum - interface - subroutine psb_lc_csc_arwsum(d,a) + interface + subroutine psb_lc_csc_arwsum(d,a) import class(psb_lc_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_csc_arwsum end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_colsum - interface - subroutine psb_lc_csc_colsum(d,a) + interface + subroutine psb_lc_csc_colsum(d,a) import class(psb_lc_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -882,18 +881,18 @@ module psb_c_csc_mat_mod !> \memberof psb_lc_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_aclsum - interface - subroutine psb_lc_csc_aclsum(d,a) + interface + subroutine psb_lc_csc_aclsum(d,a) import class(psb_lc_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_csc_aclsum end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scal - interface - subroutine psb_lc_csc_scal(d,a,info,side) + interface + subroutine psb_lc_csc_scal(d,a,info,side) import class(psb_lc_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) @@ -901,27 +900,25 @@ module psb_c_csc_mat_mod character, intent(in), optional :: side end subroutine psb_lc_csc_scal end interface - + !> \memberof psb_lc_csc_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scals interface - subroutine psb_lc_csc_scals(d,a,info) + subroutine psb_lc_csc_scals(d,a,info) import class(psb_lc_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csc_scals end interface - - -contains +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -929,54 +926,54 @@ contains ! ! == =================================== - + function c_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function c_csc_is_by_cols - + function c_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%icp) res = res + psb_sizeof_ip * psb_size(a%ia) - + end function c_csc_sizeof function c_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function c_csc_get_fmt - + function c_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%icp(a%get_ncols()+1)-1 end function c_csc_get_nzeros function c_csc_get_size(a) result(res) - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -988,17 +985,17 @@ contains function c_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function c_csc_get_nz_col @@ -1013,11 +1010,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine c_csc_free(a) - implicit none + subroutine c_csc_free(a) + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a @@ -1027,7 +1024,7 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine c_csc_free @@ -1038,7 +1035,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1046,57 +1043,57 @@ contains ! ! == =================================== - + function lc_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function lc_csc_is_by_cols ! ! lc ! - + function lc_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2*psb_sizeof_lp res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%icp) res = res + psb_sizeof_lp * psb_size(a%ia) - + end function lc_csc_sizeof function lc_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function lc_csc_get_fmt - + function lc_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%icp(a%get_ncols()+1)-1 end function lc_csc_get_nzeros function lc_csc_get_size(a) result(res) - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1108,17 +1105,17 @@ contains function lc_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_lc_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function lc_csc_get_nz_col @@ -1133,11 +1130,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine lc_csc_free(a) - implicit none + subroutine lc_csc_free(a) + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a @@ -1147,7 +1144,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine lc_csc_free diff --git a/base/modules/serial/psb_c_csr_mat_mod.f90 b/base/modules/serial/psb_c_csr_mat_mod.f90 index e3b18af01..8b076cc22 100644 --- a/base/modules/serial/psb_c_csr_mat_mod.f90 +++ b/base/modules/serial/psb_c_csr_mat_mod.f90 @@ -1,10 +1,10 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -16,7 +16,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -28,8 +28,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_c_csr_mat_mod ! @@ -48,17 +48,17 @@ module psb_c_csr_mat_mod !> \namespace psb_base_mod \class psb_c_csr_sparse_mat !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat - !! + !! !! psb_c_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_c_base_sparse_mat) :: psb_c_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_ipk_), allocatable :: irp(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_spk_), allocatable :: val(:) contains @@ -112,23 +112,23 @@ module psb_c_csr_mat_mod !> \memberof psb_c_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_c_csr_reallocate_nz(nz,a) + subroutine psb_c_csr_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_c_csr_sparse_mat), intent(inout) :: a end subroutine psb_c_csr_reallocate_nz end interface - + !> \memberof psb_c_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_c_csr_reinit(a,clear) import - class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_csr_reinit end interface - + !> \memberof psb_c_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -138,22 +138,22 @@ module psb_c_csr_mat_mod end subroutine psb_c_csr_trim end interface - + !> \memberof psb_c_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_c_csr_mold(a,b,info) + interface + subroutine psb_c_csr_mold(a,b,info) import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csr_mold end interface - + !> \memberof psb_c_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -161,14 +161,14 @@ module psb_c_csr_mat_mod end subroutine psb_c_csr_allocate_mnnz end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_print interface subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -187,27 +187,27 @@ module psb_c_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_c_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -216,13 +216,13 @@ module psb_c_csr_mat_mod class(psb_c_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_c_csr_tril end interface - + ! !> Function triu: !! \memberof psb_c_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -231,27 +231,27 @@ module psb_c_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_c_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -260,133 +260,133 @@ module psb_c_csr_mat_mod class(psb_c_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_c_csr_triu end interface - + ! - !> + !> !! \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_clean_zeros ! interface subroutine psb_c_csr_clean_zeros(a, info) - import + import class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csr_clean_zeros end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo - interface - subroutine psb_c_cp_csr_to_coo(a,b,info) + interface + subroutine psb_c_cp_csr_to_coo(a,b,info) import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csr_to_coo end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo - interface - subroutine psb_c_cp_csr_from_coo(a,b,info) + interface + subroutine psb_c_cp_csr_from_coo(a,b,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csr_from_coo end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_to_fmt - interface - subroutine psb_c_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_c_cp_csr_to_fmt(a,b,info) import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csr_to_fmt end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from_fmt - interface - subroutine psb_c_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_c_cp_csr_from_fmt(a,b,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csr_from_fmt end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_to_coo - interface - subroutine psb_c_mv_csr_to_coo(a,b,info) + interface + subroutine psb_c_mv_csr_to_coo(a,b,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csr_to_coo end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo - interface - subroutine psb_c_mv_csr_from_coo(a,b,info) + interface + subroutine psb_c_mv_csr_from_coo(a,b,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csr_from_coo end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_to_fmt - interface - subroutine psb_c_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_c_mv_csr_to_fmt(a,b,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csr_to_fmt end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt - interface - subroutine psb_c_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_c_mv_csr_from_fmt(a,b,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_mv_csr_from_fmt end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cp_from - interface + interface subroutine psb_c_csr_cp_from(a,b) import class(psb_c_csr_sparse_mat), intent(inout) :: a type(psb_c_csr_sparse_mat), intent(in) :: b end subroutine psb_c_csr_cp_from end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_mv_from - interface + interface subroutine psb_c_csr_mv_from(a,b) import class(psb_c_csr_sparse_mat), intent(inout) :: a type(psb_c_csr_sparse_mat), intent(inout) :: b end subroutine psb_c_csr_mv_from end interface - - + + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csput_a - interface - subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -395,10 +395,10 @@ module psb_c_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csr_csput_a end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -413,10 +413,10 @@ module psb_c_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_csr_csgetptn end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csgetrow - interface + interface subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import @@ -435,8 +435,8 @@ module psb_c_csr_mat_mod !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssv - interface - subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -447,8 +447,8 @@ module psb_c_csr_mat_mod end interface !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssm - interface - subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -457,11 +457,11 @@ module psb_c_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_csr_cssm end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csmv - interface - subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -473,8 +473,8 @@ module psb_c_csr_mat_mod !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csmm - interface - subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -483,32 +483,32 @@ module psb_c_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_csr_csmm end interface - - + + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_maxval - interface + interface function psb_c_csr_maxval(a) result(res) import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csr_maxval end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_csnmi - interface + interface function psb_c_csr_csnmi(a) result(res) import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csr_csnmi end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_rowsum - interface - subroutine psb_c_csr_rowsum(d,a) + interface + subroutine psb_c_csr_rowsum(d,a) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -517,18 +517,18 @@ module psb_c_csr_mat_mod !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_arwsum - interface - subroutine psb_c_csr_arwsum(d,a) + interface + subroutine psb_c_csr_arwsum(d,a) import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csr_arwsum end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_colsum - interface - subroutine psb_c_csr_colsum(d,a) + interface + subroutine psb_c_csr_colsum(d,a) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -537,29 +537,29 @@ module psb_c_csr_mat_mod !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_aclsum - interface - subroutine psb_c_csr_aclsum(d,a) + interface + subroutine psb_c_csr_aclsum(d,a) import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csr_aclsum end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_get_diag - interface - subroutine psb_c_csr_get_diag(a,d,info) + interface + subroutine psb_c_csr_get_diag(a,d,info) import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csr_get_diag end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scal - interface - subroutine psb_c_csr_scal(d,a,info,side) + interface + subroutine psb_c_csr_scal(d,a,info,side) import class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) @@ -567,32 +567,31 @@ module psb_c_csr_mat_mod character, intent(in), optional :: side end subroutine psb_c_csr_scal end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_scals interface - subroutine psb_c_csr_scals(d,a,info) + subroutine psb_c_csr_scals(d,a,info) import class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csr_scals end interface - !> \namespace psb_base_mod \class psb_lc_csr_sparse_mat !! \extends psb_lc_base_mat_mod::psb_lc_base_sparse_mat - !! + !! !! psb_lc_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_lc_base_sparse_mat) :: psb_lc_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_lpk_), allocatable :: irp(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_spk_), allocatable :: val(:) contains @@ -642,23 +641,23 @@ module psb_c_csr_mat_mod !> \memberof psb_lc_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_lc_csr_reallocate_nz(nz,a) + subroutine psb_lc_csr_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_lc_csr_sparse_mat), intent(inout) :: a end subroutine psb_lc_csr_reallocate_nz end interface - + !> \memberof psb_lc_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_lc_csr_reinit(a,clear) import - class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lc_csr_reinit end interface - + !> \memberof psb_lc_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -668,22 +667,22 @@ module psb_c_csr_mat_mod end subroutine psb_lc_csr_trim end interface - + !> \memberof psb_lc_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lc_csr_mold(a,b,info) + interface + subroutine psb_lc_csr_mold(a,b,info) import class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csr_mold end interface - + !> \memberof psb_lc_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_lc_csr_sparse_mat), intent(inout) :: a @@ -691,14 +690,14 @@ module psb_c_csr_mat_mod end subroutine psb_lc_csr_allocate_mnnz end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_print interface subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -717,27 +716,27 @@ module psb_c_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lc_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -746,13 +745,13 @@ module psb_c_csr_mat_mod class(psb_lc_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_lc_csr_tril end interface - + ! !> Function triu: !! \memberof psb_c_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -761,27 +760,27 @@ module psb_c_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lc_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -792,133 +791,133 @@ module psb_c_csr_mat_mod end interface ! - !> + !> !! \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros ! interface subroutine psb_lc_csr_clean_zeros(a, info) - import + import class(psb_lc_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csr_clean_zeros end interface - - + + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo - interface - subroutine psb_lc_cp_csr_to_coo(a,b,info) + interface + subroutine psb_lc_cp_csr_to_coo(a,b,info) import class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csr_to_coo end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo - interface - subroutine psb_lc_cp_csr_from_coo(a,b,info) + interface + subroutine psb_lc_cp_csr_from_coo(a,b,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csr_from_coo end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_fmt - interface - subroutine psb_lc_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_lc_cp_csr_to_fmt(a,b,info) import class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csr_to_fmt end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt - interface - subroutine psb_lc_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_lc_cp_csr_from_fmt(a,b,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_cp_csr_from_fmt end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo - interface - subroutine psb_lc_mv_csr_to_coo(a,b,info) + interface + subroutine psb_lc_mv_csr_to_coo(a,b,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csr_to_coo end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo - interface - subroutine psb_lc_mv_csr_from_coo(a,b,info) + interface + subroutine psb_lc_mv_csr_from_coo(a,b,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csr_from_coo end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt - interface - subroutine psb_lc_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_lc_mv_csr_to_fmt(a,b,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csr_to_fmt end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt - interface - subroutine psb_lc_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_lc_mv_csr_from_fmt(a,b,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_mv_csr_from_fmt end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from - interface + interface subroutine psb_lc_csr_cp_from(a,b) import class(psb_lc_csr_sparse_mat), intent(inout) :: a type(psb_lc_csr_sparse_mat), intent(in) :: b end subroutine psb_lc_csr_cp_from end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from - interface + interface subroutine psb_lc_csr_mv_from(a,b) import class(psb_lc_csr_sparse_mat), intent(inout) :: a type(psb_lc_csr_sparse_mat), intent(inout) :: b end subroutine psb_lc_csr_mv_from end interface - - + + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a - interface - subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -927,10 +926,10 @@ module psb_c_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csr_csput_a end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -945,10 +944,10 @@ module psb_c_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csr_csgetptn end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow - interface + interface subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -964,11 +963,11 @@ module psb_c_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csr_csgetrow end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag - interface - subroutine psb_lc_csr_get_diag(a,d,info) + interface + subroutine psb_lc_csr_get_diag(a,d,info) import class(psb_lc_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -978,8 +977,8 @@ module psb_c_csr_mat_mod !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scal - interface - subroutine psb_lc_csr_scal(d,a,info,side) + interface + subroutine psb_lc_csr_scal(d,a,info,side) import class(psb_lc_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) @@ -987,42 +986,42 @@ module psb_c_csr_mat_mod character, intent(in), optional :: side end subroutine psb_lc_csr_scal end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_lc_base_mat_mod::psb_lc_base_scals interface - subroutine psb_lc_csr_scals(d,a,info) + subroutine psb_lc_csr_scals(d,a,info) import class(psb_lc_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csr_scals end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_maxval - interface + interface function psb_lc_csr_maxval(a) result(res) import class(psb_lc_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_csr_maxval end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_csnmi - interface + interface function psb_lc_csr_csnmi(a) result(res) import class(psb_lc_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_lc_csr_csnmi end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_rowsum - interface - subroutine psb_lc_csr_rowsum(d,a) + interface + subroutine psb_lc_csr_rowsum(d,a) import class(psb_lc_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -1031,18 +1030,18 @@ module psb_c_csr_mat_mod !> \memberof psb_lc_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_arwsum - interface - subroutine psb_lc_csr_arwsum(d,a) + interface + subroutine psb_lc_csr_arwsum(d,a) import class(psb_lc_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_csr_arwsum end interface - + !> \memberof psb_lc_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_colsum - interface - subroutine psb_lc_csr_colsum(d,a) + interface + subroutine psb_lc_csr_colsum(d,a) import class(psb_lc_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) @@ -1051,22 +1050,22 @@ module psb_c_csr_mat_mod !> \memberof psb_lc_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_lc_base_aclsum - interface - subroutine psb_lc_csr_aclsum(d,a) + interface + subroutine psb_lc_csr_aclsum(d,a) import class(psb_lc_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_lc_csr_aclsum end interface - -contains + +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1075,54 +1074,54 @@ contains ! == =================================== - + function c_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function c_csr_is_by_rows - + function c_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function c_csr_sizeof function c_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function c_csr_get_fmt - + function c_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%irp(a%get_nrows()+1)-1 end function c_csr_get_nzeros function c_csr_get_size(a) result(res) - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1134,17 +1133,17 @@ contains function c_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function c_csr_get_nz_row @@ -1159,10 +1158,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine c_csr_free(a) - implicit none + subroutine c_csr_free(a) + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a @@ -1172,18 +1171,18 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine c_csr_free - + ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1192,54 +1191,54 @@ contains ! == =================================== - + function lc_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function lc_csr_is_by_rows - + function lc_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 2 * psb_sizeof_lp + res = 2 * psb_sizeof_lp res = res + (2*psb_sizeof_sp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%irp) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function lc_csr_sizeof function lc_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function lc_csr_get_fmt - + function lc_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%irp(a%get_nrows()+1)-1 end function lc_csr_get_nzeros function lc_csr_get_size(a) result(res) - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1251,17 +1250,17 @@ contains function lc_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_lc_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function lc_csr_get_nz_row @@ -1276,10 +1275,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine lc_csr_free(a) - implicit none + subroutine lc_csr_free(a) + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a @@ -1289,7 +1288,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine lc_csr_free diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 index a24b40e2a..76225758b 100644 --- a/base/modules/serial/psb_c_mat_mod.F90 +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_c_mat_mod ! @@ -37,7 +37,7 @@ ! provide a mean of switching, at run-time, among different formats, ! potentially unknown at the library compile-time by adding a layer of ! indirection. This type encapsulates the psb_c_base_sparse_mat class -! inside another class which is the one visible to the user. +! inside another class which is the one visible to the user. ! Most methods of the psb_c_mat_mod simply call the methods of the ! encapsulated class. ! The exceptions are mainly cscnv and cp_from/cp_to; these provide @@ -48,14 +48,14 @@ ! through the application life. ! In particular, computational methods can only be invoked when ! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the ! following state transition table. Associated with these states are ! the possible dynamic types of the inner matrix object. ! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method !| ---------------------------------- !| Null Build csall !| Build Build csput @@ -64,7 +64,7 @@ !| Assembled Update reinit !| Update Update csput !| Update Assembled cscnv -!| * unchanged reall +!| * unchanged reall !| Assembled Null free ! ! @@ -74,7 +74,7 @@ ! of the indices, which are PSB_LPK_ so that the entries ! are guaranteed to be able to contain global indices. ! This type only supports data handling and preprocessing, it is -! not supposed to be used for computations. +! not supposed to be used for computations. ! module psb_c_mat_mod @@ -84,7 +84,7 @@ module psb_c_mat_mod type :: psb_cspmat_type - class(psb_c_base_sparse_mat), allocatable :: a + class(psb_c_base_sparse_mat), allocatable :: a contains ! Getters @@ -126,12 +126,12 @@ module psb_c_mat_mod procedure, pass(a) :: set_unit => psb_c_set_unit procedure, pass(a) :: set_repeatable_updates => psb_c_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_c_csall procedure, pass(a) :: free => psb_c_free procedure, pass(a) :: trim => psb_c_trim procedure, pass(a) :: csput_a => psb_c_csput_a - procedure, pass(a) :: csput_v => psb_c_csput_v + procedure, pass(a) :: csput_v => psb_c_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_c_csgetptn procedure, pass(a) :: csgetrow => psb_c_csgetrow @@ -141,7 +141,7 @@ module psb_c_mat_mod procedure, pass(a) :: lcsgetptn => psb_c_lcsgetptn procedure, pass(a) :: lcsgetrow => psb_c_lcsgetrow generic, public :: csget => lcsgetptn, lcsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_c_tril procedure, pass(a) :: triu => psb_c_triu procedure, pass(a) :: m_csclip => psb_c_csclip @@ -169,7 +169,7 @@ module psb_c_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => c_mat_sync procedure, pass(a) :: is_host => c_mat_is_host @@ -205,16 +205,16 @@ module psb_c_mat_mod procedure, pass(a) :: mv_to_lb => psb_c_mv_to_lb procedure, pass(a) :: cp_from_lb => psb_c_cp_from_lb procedure, pass(a) :: cp_to_lb => psb_c_cp_to_lb - procedure, pass(a) :: mv_from_l => psb_c_mv_from_l - procedure, pass(a) :: mv_to_l => psb_c_mv_to_l - procedure, pass(a) :: cp_from_l => psb_c_cp_from_l - procedure, pass(a) :: cp_to_l => psb_c_cp_to_l + procedure, pass(a) :: mv_from_l => psb_c_mv_from_l + procedure, pass(a) :: mv_to_l => psb_c_mv_to_l + procedure, pass(a) :: cp_from_l => psb_c_cp_from_l + procedure, pass(a) :: cp_to_l => psb_c_cp_to_l generic, public :: mv_from => mv_from_lb, mv_from_l generic, public :: mv_to => mv_to_lb, mv_to_l generic, public :: cp_from => cp_from_lb, cp_from_l generic, public :: cp_to => cp_to_lb, cp_to_l - - ! Computational routines + + ! Computational routines procedure, pass(a) :: get_diag => psb_c_get_diag procedure, pass(a) :: maxval => psb_c_maxval procedure, pass(a) :: spnmi => psb_c_csnmi @@ -234,6 +234,11 @@ module psb_c_mat_mod procedure, pass(a) :: cssv => psb_c_cssv procedure, pass(a) :: cssm => psb_c_cssm generic, public :: spsm => cssm, cssv, cssv_v + procedure, pass(a) :: scalpid => psb_c_scalplusidentity + procedure, pass(a) :: spaxpby => psb_c_spaxpby + procedure, pass(a) :: cmpval => psb_c_cmpval + procedure, pass(a) :: cmpmat => psb_c_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_cspmat_type @@ -267,7 +272,7 @@ module psb_c_mat_mod type :: psb_lcspmat_type - class(psb_lc_base_sparse_mat), allocatable :: a + class(psb_lc_base_sparse_mat), allocatable :: a contains ! Getters @@ -296,7 +301,7 @@ module psb_c_mat_mod ! Setters procedure, pass(a) :: set_lnrows => psb_lc_set_lnrows procedure, pass(a) :: set_lncols => psb_lc_set_lncols -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) procedure, pass(a) :: set_inrows => psb_lc_set_inrows procedure, pass(a) :: set_incols => psb_lc_set_incols generic, public :: set_nrows => set_inrows, set_lnrows @@ -305,7 +310,7 @@ module psb_c_mat_mod generic, public :: set_nrows => set_lnrows generic, public :: set_ncols => set_lncols #endif - + procedure, pass(a) :: set_dupl => psb_lc_set_dupl procedure, pass(a) :: set_null => psb_lc_set_null procedure, pass(a) :: set_bld => psb_lc_set_bld @@ -319,12 +324,12 @@ module psb_c_mat_mod procedure, pass(a) :: set_unit => psb_lc_set_unit procedure, pass(a) :: set_repeatable_updates => psb_lc_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_lc_csall procedure, pass(a) :: free => psb_lc_free procedure, pass(a) :: trim => psb_lc_trim procedure, pass(a) :: csput_a => psb_lc_csput_a - procedure, pass(a) :: csput_v => psb_lc_csput_v + procedure, pass(a) :: csput_v => psb_lc_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_lc_csgetptn procedure, pass(a) :: csgetrow => psb_lc_csgetrow @@ -334,7 +339,7 @@ module psb_c_mat_mod !!$ procedure, pass(a) :: icsgetptn => psb_lc_icsgetptn !!$ procedure, pass(a) :: icsgetrow => psb_lc_icsgetrow !!$ generic, public :: csget => icsgetptn, icsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_lc_tril procedure, pass(a) :: triu => psb_lc_triu procedure, pass(a) :: m_csclip => psb_lc_csclip @@ -362,7 +367,7 @@ module psb_c_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => lc_mat_sync procedure, pass(a) :: is_host => lc_mat_is_host @@ -398,16 +403,16 @@ module psb_c_mat_mod procedure, pass(a) :: mv_to_ib => psb_lc_mv_to_ib procedure, pass(a) :: cp_from_ib => psb_lc_cp_from_ib procedure, pass(a) :: cp_to_ib => psb_lc_cp_to_ib - procedure, pass(a) :: mv_from_i => psb_lc_mv_from_i - procedure, pass(a) :: mv_to_i => psb_lc_mv_to_i - procedure, pass(a) :: cp_from_i => psb_lc_cp_from_i - procedure, pass(a) :: cp_to_i => psb_lc_cp_to_i + procedure, pass(a) :: mv_from_i => psb_lc_mv_from_i + procedure, pass(a) :: mv_to_i => psb_lc_mv_to_i + procedure, pass(a) :: cp_from_i => psb_lc_cp_from_i + procedure, pass(a) :: cp_to_i => psb_lc_cp_to_i generic, public :: mv_from => mv_from_ib, mv_from_i generic, public :: mv_to => mv_to_ib, mv_to_i generic, public :: cp_from => cp_from_ib, cp_from_i generic, public :: cp_to => cp_to_ib, cp_to_i - ! Computational routines + ! Computational routines procedure, pass(a) :: get_diag => psb_lc_get_diag procedure, pass(a) :: maxval => psb_lc_maxval procedure, pass(a) :: spnmi => psb_lc_csnmi @@ -419,6 +424,11 @@ module psb_c_mat_mod procedure, pass(a) :: scals => psb_lc_scals procedure, pass(a) :: scalv => psb_lc_scal generic, public :: scal => scals, scalv + procedure, pass(a) :: scalpid => psb_lc_scalplusidentity + procedure, pass(a) :: spaxpby => psb_lc_spaxpby + procedure, pass(a) :: cmpval => psb_lc_cmpval + procedure, pass(a) :: cmpmat => psb_lc_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_lcspmat_type @@ -449,7 +459,7 @@ module psb_c_mat_mod ! ! ! - ! Setters + ! Setters ! ! ! @@ -459,142 +469,142 @@ module psb_c_mat_mod ! == =================================== - interface - subroutine psb_c_set_nrows(m,a) + interface + subroutine psb_c_set_nrows(m,a) import :: psb_ipk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_c_set_nrows end interface - - interface - subroutine psb_c_set_ncols(n,a) + + interface + subroutine psb_c_set_ncols(n,a) import :: psb_ipk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_c_set_ncols end interface - - interface - subroutine psb_c_set_dupl(n,a) + + interface + subroutine psb_c_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_c_set_dupl end interface - - interface - subroutine psb_c_set_null(a) + + interface + subroutine psb_c_set_null(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_null end interface - - interface - subroutine psb_c_set_bld(a) + + interface + subroutine psb_c_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_bld end interface - - interface - subroutine psb_c_set_upd(a) + + interface + subroutine psb_c_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_upd end interface - - interface - subroutine psb_c_set_asb(a) + + interface + subroutine psb_c_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_set_asb end interface - - interface - subroutine psb_c_set_sorted(a,val) + + interface + subroutine psb_c_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_sorted end interface - - interface - subroutine psb_c_set_triangle(a,val) + + interface + subroutine psb_c_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_triangle end interface - - interface - subroutine psb_c_set_symmetric(a,val) + + interface + subroutine psb_c_set_symmetric(a,val) import :: psb_ipk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_symmetric end interface - - interface - subroutine psb_c_set_unit(a,val) + + interface + subroutine psb_c_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_unit end interface - - interface - subroutine psb_c_set_lower(a,val) + + interface + subroutine psb_c_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_lower end interface - - interface - subroutine psb_c_set_upper(a,val) + + interface + subroutine psb_c_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_c_set_upper end interface - - interface + + interface subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_cspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_c_sparse_print end interface - interface + interface subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_cspmat_type character(len=*), intent(in) :: fname - class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_c_n_sparse_print end interface - - interface + + interface subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_cspmat_type - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev end subroutine psb_c_get_neigh end interface - - interface - subroutine psb_c_csall(nr,nc,a,info,nz) + + interface + subroutine psb_c_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc @@ -602,31 +612,31 @@ module psb_c_mat_mod integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_c_csall end interface - - interface - subroutine psb_c_reallocate_nz(nz,a) + + interface + subroutine psb_c_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_reallocate_nz end interface - - interface - subroutine psb_c_free(a) + + interface + subroutine psb_c_free(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_free end interface - - interface - subroutine psb_c_trim(a) + + interface + subroutine psb_c_trim(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_trim end interface - - interface - subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -635,9 +645,9 @@ module psb_c_mat_mod end subroutine psb_c_csput_a end interface - - interface - subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_vect_mod, only : psb_c_vect_type use psb_i_vect_mod, only : psb_i_vect_type import :: psb_ipk_, psb_lpk_, psb_cspmat_type @@ -648,8 +658,8 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csput_v end interface - - interface + + interface subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -664,8 +674,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_csgetptn end interface - - interface + + interface subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -681,8 +691,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_csgetrow end interface - - interface + + interface subroutine psb_c_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -696,8 +706,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_csgetblk end interface - - interface + + interface subroutine psb_c_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -709,8 +719,8 @@ module psb_c_mat_mod class(psb_cspmat_type), optional, intent(inout) :: u end subroutine psb_c_tril end interface - - interface + + interface subroutine psb_c_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -724,7 +734,7 @@ module psb_c_mat_mod end interface - interface + interface subroutine psb_c_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -736,7 +746,7 @@ module psb_c_mat_mod end subroutine psb_c_csclip end interface - interface + interface subroutine psb_c_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -746,8 +756,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_csclip_ip end interface - - interface + + interface subroutine psb_c_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_coo_sparse_mat @@ -758,60 +768,60 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_c_b_csclip end interface - - interface + + interface subroutine psb_c_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_c_mold end interface - - interface - subroutine psb_c_asb(a,mold) + + interface + subroutine psb_c_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_c_asb end interface - - interface + + interface subroutine psb_c_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_transp_1mat end interface - - interface + + interface subroutine psb_c_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b end subroutine psb_c_transp_2mat end interface - - interface + + interface subroutine psb_c_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a end subroutine psb_c_transc_1mat end interface - - interface + + interface subroutine psb_c_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b end subroutine psb_c_transc_2mat end interface - - interface + + interface subroutine psb_c_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_reinit - + end interface @@ -826,9 +836,9 @@ module psb_c_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(in) :: a @@ -839,9 +849,9 @@ module psb_c_mat_mod class(psb_c_base_sparse_mat), intent(in), optional :: mold end subroutine psb_c_cscnv end interface - - interface + + interface subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a @@ -851,9 +861,9 @@ module psb_c_mat_mod class(psb_c_base_sparse_mat), intent(in), optional :: mold end subroutine psb_c_cscnv_ip end interface - - interface + + interface subroutine psb_c_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(in) :: a @@ -862,12 +872,12 @@ module psb_c_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_c_cscnv_base end interface - + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_c_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(in) :: a @@ -875,46 +885,46 @@ module psb_c_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_c_clip_d end interface - - interface + + interface subroutine psb_c_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_c_clip_d_ip end interface - + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_c_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_c_mv_from end interface - - interface + + interface subroutine psb_c_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(out) :: a class(psb_c_base_sparse_mat), intent(in) :: b end subroutine psb_c_cp_from end interface - - interface + + interface subroutine psb_c_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_c_mv_to end interface - - interface + + interface subroutine psb_c_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_c_cp_to @@ -922,63 +932,63 @@ module psb_c_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_c_mv_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_c_mv_from_lb end interface - - interface + + interface subroutine psb_c_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_cspmat_type), intent(out) :: a class(psb_lc_base_sparse_mat), intent(in) :: b end subroutine psb_c_cp_from_lb end interface - - interface + + interface subroutine psb_c_mv_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_c_mv_to_lb end interface - - interface + + interface subroutine psb_c_cp_to_lb(a,b) - import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_cspmat_type), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_c_cp_to_lb end interface - interface + interface subroutine psb_c_mv_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type class(psb_cspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: b end subroutine psb_c_mv_from_l end interface - - interface + + interface subroutine psb_c_cp_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type class(psb_cspmat_type), intent(out) :: a class(psb_lcspmat_type), intent(in) :: b end subroutine psb_c_cp_from_l end interface - - interface + + interface subroutine psb_c_mv_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type class(psb_cspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: b end subroutine psb_c_mv_to_l end interface - - interface + + interface subroutine psb_c_cp_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type class(psb_cspmat_type), intent(in) :: a @@ -988,8 +998,8 @@ module psb_c_mat_mod ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_cspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a @@ -997,8 +1007,8 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_cspmat_type_move end interface - - interface + + interface subroutine psb_cspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_cspmat_type class(psb_cspmat_type), intent(inout) :: a @@ -1024,7 +1034,7 @@ module psb_c_mat_mod ! == =================================== interface psb_csmm - subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) + subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -1032,7 +1042,7 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_c_csmm - subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -1040,7 +1050,7 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_c_csmv - subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) + subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_c_vect_mod, only : psb_c_vect_type import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1051,9 +1061,9 @@ module psb_c_mat_mod character, optional, intent(in) :: trans end subroutine psb_c_csmv_vect end interface - + interface psb_cssm - subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -1062,7 +1072,7 @@ module psb_c_mat_mod character, optional, intent(in) :: trans, scale complex(psb_spk_), intent(in), optional :: d(:) end subroutine psb_c_cssm - subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -1071,7 +1081,7 @@ module psb_c_mat_mod character, optional, intent(in) :: trans, scale complex(psb_spk_), intent(in), optional :: d(:) end subroutine psb_c_cssv - subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_c_vect_mod, only : psb_c_vect_type import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1083,24 +1093,24 @@ module psb_c_mat_mod type(psb_c_vect_type), optional, intent(inout) :: d end subroutine psb_c_cssv_vect end interface - - interface + + interface function psb_c_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_c_maxval end interface - - interface + + interface function psb_c_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_c_csnmi end interface - - interface + + interface function psb_c_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1108,7 +1118,7 @@ module psb_c_mat_mod end function psb_c_csnm1 end interface - interface + interface function psb_c_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1117,7 +1127,7 @@ module psb_c_mat_mod end function psb_c_rowsum end interface - interface + interface function psb_c_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1125,8 +1135,8 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_c_arwsum end interface - - interface + + interface function psb_c_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1135,7 +1145,7 @@ module psb_c_mat_mod end function psb_c_colsum end interface - interface + interface function psb_c_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1144,7 +1154,7 @@ module psb_c_mat_mod end function psb_c_aclsum end interface - interface + interface function psb_c_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ class(psb_cspmat_type), intent(in) :: a @@ -1152,7 +1162,7 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_c_get_diag end interface - + interface psb_scal subroutine psb_c_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ @@ -1169,12 +1179,53 @@ module psb_c_mat_mod end subroutine psb_c_scals end interface + interface psb_scalplusidentity + subroutine psb_c_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_c_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_spaxpby + end interface + + interface + function psb_c_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_c_cmpval + end interface + + interface + function psb_c_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_c_cmpmat + end interface ! == =================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -1184,156 +1235,156 @@ module psb_c_mat_mod ! == =================================== - interface - subroutine psb_lc_set_lnrows(m,a) + interface + subroutine psb_lc_set_lnrows(m,a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m end subroutine psb_lc_set_lnrows #if defined(IPK4) && defined(LPK8) - subroutine psb_lc_set_inrows(m,a) + subroutine psb_lc_set_inrows(m,a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_lc_set_inrows #endif end interface - - interface - subroutine psb_lc_set_lncols(n,a) + + interface + subroutine psb_lc_set_lncols(n,a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n end subroutine psb_lc_set_lncols -#if defined(IPK4) && defined(LPK8) - subroutine psb_lc_set_incols(n,a) +#if defined(IPK4) && defined(LPK8) + subroutine psb_lc_set_incols(n,a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_lc_set_incols #endif end interface - - interface - subroutine psb_lc_set_dupl(n,a) + + interface + subroutine psb_lc_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_lc_set_dupl end interface - - interface - subroutine psb_lc_set_null(a) + + interface + subroutine psb_lc_set_null(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_set_null end interface - - interface - subroutine psb_lc_set_bld(a) + + interface + subroutine psb_lc_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_set_bld end interface - - interface - subroutine psb_lc_set_upd(a) + + interface + subroutine psb_lc_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_set_upd end interface - - interface - subroutine psb_lc_set_asb(a) + + interface + subroutine psb_lc_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_set_asb end interface - - interface - subroutine psb_lc_set_sorted(a,val) + + interface + subroutine psb_lc_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lc_set_sorted end interface - - interface - subroutine psb_lc_set_triangle(a,val) + + interface + subroutine psb_lc_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lc_set_triangle end interface - - interface - subroutine psb_lc_set_symmetric(a,val) + + interface + subroutine psb_lc_set_symmetric(a,val) import :: psb_ipk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lc_set_symmetric end interface - - interface - subroutine psb_lc_set_unit(a,val) + + interface + subroutine psb_lc_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lc_set_unit end interface - - interface - subroutine psb_lc_set_lower(a,val) + + interface + subroutine psb_lc_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lc_set_lower end interface - - interface - subroutine psb_lc_set_upper(a,val) + + interface + subroutine psb_lc_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lc_set_upper end interface - - interface + + interface subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lc_sparse_print end interface - interface + interface subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type character(len=*), intent(in) :: fname - class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lc_n_sparse_print end interface - - interface + + interface subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type - class(psb_lcspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev end subroutine psb_lc_get_neigh end interface - - interface - subroutine psb_lc_csall(nr,nc,a,info,nz) + + interface + subroutine psb_lc_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc @@ -1341,31 +1392,31 @@ module psb_c_mat_mod integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_lc_csall end interface - - interface - subroutine psb_lc_reallocate_nz(nz,a) + + interface + subroutine psb_lc_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type integer(psb_lpk_), intent(in) :: nz class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_reallocate_nz end interface - - interface - subroutine psb_lc_free(a) + + interface + subroutine psb_lc_free(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_free end interface - - interface - subroutine psb_lc_trim(a) + + interface + subroutine psb_lc_trim(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_trim end interface - - interface - subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -1374,9 +1425,9 @@ module psb_c_mat_mod end subroutine psb_lc_csput_a end interface - - interface - subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_vect_mod, only : psb_c_vect_type use psb_l_vect_mod, only : psb_l_vect_type import :: psb_ipk_, psb_lpk_, psb_lcspmat_type @@ -1387,8 +1438,8 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_csput_v end interface - - interface + + interface subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1403,8 +1454,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csgetptn end interface - - interface + + interface subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1420,8 +1471,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csgetrow end interface - - interface + + interface subroutine psb_lc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1435,8 +1486,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csgetblk end interface - - interface + + interface subroutine psb_lc_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1448,8 +1499,8 @@ module psb_c_mat_mod class(psb_lcspmat_type), optional, intent(inout) :: u end subroutine psb_lc_tril end interface - - interface + + interface subroutine psb_lc_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1463,7 +1514,7 @@ module psb_c_mat_mod end interface - interface + interface subroutine psb_lc_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1475,7 +1526,7 @@ module psb_c_mat_mod end subroutine psb_lc_csclip end interface - interface + interface subroutine psb_lc_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1485,8 +1536,8 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_csclip_ip end interface - - interface + + interface subroutine psb_lc_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_coo_sparse_mat @@ -1497,60 +1548,60 @@ module psb_c_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lc_b_csclip end interface - - interface + + interface subroutine psb_lc_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_lc_mold end interface - - interface - subroutine psb_lc_asb(a,mold) + + interface + subroutine psb_lc_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_lc_asb end interface - - interface + + interface subroutine psb_lc_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_transp_1mat end interface - - interface + + interface subroutine psb_lc_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: b end subroutine psb_lc_transp_2mat end interface - - interface + + interface subroutine psb_lc_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a end subroutine psb_lc_transc_1mat end interface - - interface + + interface subroutine psb_lc_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: b end subroutine psb_lc_transc_2mat end interface - - interface + + interface subroutine psb_lc_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type - class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lc_reinit - + end interface @@ -1565,9 +1616,9 @@ module psb_c_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(in) :: a @@ -1578,9 +1629,9 @@ module psb_c_mat_mod class(psb_lc_base_sparse_mat), intent(in), optional :: mold end subroutine psb_lc_cscnv end interface - - interface + + interface subroutine psb_lc_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a @@ -1590,9 +1641,9 @@ module psb_c_mat_mod class(psb_lc_base_sparse_mat), intent(in), optional :: mold end subroutine psb_lc_cscnv_ip end interface - - interface + + interface subroutine psb_lc_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(in) :: a @@ -1601,13 +1652,13 @@ module psb_c_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_lc_cscnv_base end interface - - + + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_lc_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(in) :: a @@ -1615,47 +1666,47 @@ module psb_c_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_lc_clip_d end interface - - interface + + interface subroutine psb_lc_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_lc_clip_d_ip end interface - - + + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_lc_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_mv_from end interface - - interface + + interface subroutine psb_lc_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(out) :: a class(psb_lc_base_sparse_mat), intent(in) :: b end subroutine psb_lc_cp_from end interface - - interface + + interface subroutine psb_lc_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_mv_to end interface - - interface + + interface subroutine psb_lc_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat class(psb_lcspmat_type), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_cp_to @@ -1663,63 +1714,63 @@ module psb_c_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_lc_mv_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_mv_from_ib end interface - - interface + + interface subroutine psb_lc_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_lcspmat_type), intent(out) :: a class(psb_c_base_sparse_mat), intent(in) :: b end subroutine psb_lc_cp_from_ib end interface - - interface + + interface subroutine psb_lc_mv_to_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_lcspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_mv_to_ib end interface - - interface + + interface subroutine psb_lc_cp_to_ib(a,b) - import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat class(psb_lcspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b end subroutine psb_lc_cp_to_ib end interface - interface + interface subroutine psb_lc_mv_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type class(psb_lcspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b end subroutine psb_lc_mv_from_i end interface - - interface + + interface subroutine psb_lc_cp_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type class(psb_lcspmat_type), intent(out) :: a class(psb_cspmat_type), intent(in) :: b end subroutine psb_lc_cp_from_i end interface - - interface + + interface subroutine psb_lc_mv_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type class(psb_lcspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b end subroutine psb_lc_mv_to_i end interface - - interface + + interface subroutine psb_lc_cp_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type class(psb_lcspmat_type), intent(in) :: a @@ -1727,11 +1778,11 @@ module psb_c_mat_mod end subroutine psb_lc_cp_to_i end interface - + ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_lcspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a @@ -1739,8 +1790,8 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lcspmat_type_move end interface - - interface + + interface subroutine psb_lcspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type class(psb_lcspmat_type), intent(inout) :: a @@ -1751,7 +1802,7 @@ module psb_c_mat_mod - interface + interface function psb_lc_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a @@ -1759,7 +1810,7 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_lc_get_diag end interface - + interface psb_scal subroutine psb_lc_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ @@ -1776,23 +1827,43 @@ module psb_c_mat_mod end subroutine psb_lc_scals end interface - interface + interface psb_scalplusidentity + subroutine psb_lc_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_lc_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_spaxpby + end interface + + interface function psb_lc_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_lc_maxval end interface - - interface + + interface function psb_lc_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_lc_csnmi end interface - - interface + + interface function psb_lc_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a @@ -1800,7 +1871,7 @@ module psb_c_mat_mod end function psb_lc_csnm1 end interface - interface + interface function psb_lc_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a @@ -1809,7 +1880,7 @@ module psb_c_mat_mod end function psb_lc_rowsum end interface - interface + interface function psb_lc_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a @@ -1817,8 +1888,8 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_lc_arwsum end interface - - interface + + interface function psb_lc_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a @@ -1827,7 +1898,7 @@ module psb_c_mat_mod end function psb_lc_colsum end interface - interface + interface function psb_lc_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ class(psb_lcspmat_type), intent(in) :: a @@ -1835,40 +1906,59 @@ module psb_c_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_lc_aclsum end interface - -contains - subroutine psb_c_set_mat_default(a) - implicit none + interface psb_cmpmat + function psb_lc_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lc_cmpval + function psb_lc_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lc_cmpmat + end interface + +contains + + subroutine psb_c_set_mat_default(a) + implicit none class(psb_c_base_sparse_mat), intent(in) :: a - - if (allocated(psb_c_base_mat_default)) then + + if (allocated(psb_c_base_mat_default)) then deallocate(psb_c_base_mat_default) end if allocate(psb_c_base_mat_default, mold=a) end subroutine psb_c_set_mat_default - + function psb_c_get_mat_default(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), pointer :: res - + res => psb_c_get_base_mat_default() - + end function psb_c_get_mat_default - + function psb_c_get_base_mat_default() result(res) - implicit none + implicit none class(psb_c_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_c_base_mat_default)) then + + if (.not.allocated(psb_c_base_mat_default)) then allocate(psb_c_csr_sparse_mat :: psb_c_base_mat_default) end if res => psb_c_base_mat_default - + end function psb_c_get_base_mat_default subroutine psb_c_clear_mat_default() @@ -1886,7 +1976,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1894,26 +1984,26 @@ contains ! ! == =================================== - + function psb_c_sizeof(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_c_sizeof function psb_c_get_fmt(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -1923,11 +2013,11 @@ contains function psb_c_get_dupl(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -1935,11 +2025,11 @@ contains end function psb_c_get_dupl function psb_c_get_nrows(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -1948,11 +2038,11 @@ contains end function psb_c_get_nrows function psb_c_get_ncols(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -1961,11 +2051,11 @@ contains end function psb_c_get_ncols function psb_c_is_triangle(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -1974,11 +2064,11 @@ contains end function psb_c_is_triangle function psb_c_is_symmetric(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -1987,11 +2077,11 @@ contains end function psb_c_is_symmetric function psb_c_is_unit(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2000,11 +2090,11 @@ contains end function psb_c_is_unit function psb_c_is_upper(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2013,11 +2103,11 @@ contains end function psb_c_is_upper function psb_c_is_lower(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2026,12 +2116,12 @@ contains end function psb_c_is_lower function psb_c_is_null(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2039,11 +2129,11 @@ contains end function psb_c_is_null function psb_c_is_bld(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2052,11 +2142,11 @@ contains end function psb_c_is_bld function psb_c_is_upd(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2065,11 +2155,11 @@ contains end function psb_c_is_upd function psb_c_is_asb(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2078,11 +2168,11 @@ contains end function psb_c_is_asb function psb_c_is_sorted(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2091,11 +2181,11 @@ contains end function psb_c_is_sorted function psb_c_is_by_rows(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2104,11 +2194,11 @@ contains end function psb_c_is_by_rows function psb_c_is_by_cols(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2119,61 +2209,61 @@ contains ! subroutine c_mat_sync(a) - implicit none + implicit none class(psb_cspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine c_mat_sync ! subroutine c_mat_set_host(a) - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine c_mat_set_host ! subroutine c_mat_set_dev(a) - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine c_mat_set_dev ! subroutine c_mat_set_sync(a) - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine c_mat_set_sync ! function c_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function c_mat_is_dev - + ! function c_mat_is_host(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2183,11 +2273,11 @@ contains ! function c_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2198,11 +2288,11 @@ contains function psb_c_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2210,25 +2300,25 @@ contains end function psb_c_is_repeatable_updates - subroutine psb_c_set_repeatable_updates(a,val) - implicit none + subroutine psb_c_set_repeatable_updates(a,val) + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_c_set_repeatable_updates function psb_c_get_nzeros(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2236,13 +2326,13 @@ contains function psb_c_get_size(a) result(res) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2250,23 +2340,23 @@ contains function psb_c_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_ipk_), intent(in) :: idx class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_c_get_nz_row subroutine psb_c_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_cspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_c_clean_zeros @@ -2274,7 +2364,7 @@ contains #if defined(IPK4) && defined(LPK8) subroutine psb_c_lcsgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2303,17 +2393,17 @@ contains end if call a%csget(imin,imax,nz,lia,lja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_c_lcsgetptn - + subroutine psb_c_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2342,12 +2432,12 @@ contains call a%csget(imin,imax,nz,lia,lja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_c_lcsgetrow #endif @@ -2355,38 +2445,38 @@ contains ! lc methods ! - - subroutine psb_lc_set_mat_default(a) - implicit none + + subroutine psb_lc_set_mat_default(a) + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a - - if (allocated(psb_lc_base_mat_default)) then + + if (allocated(psb_lc_base_mat_default)) then deallocate(psb_lc_base_mat_default) end if allocate(psb_lc_base_mat_default, mold=a) end subroutine psb_lc_set_mat_default - + function psb_lc_get_mat_default(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lc_base_sparse_mat), pointer :: res - + res => psb_lc_get_base_mat_default() - + end function psb_lc_get_mat_default - + function psb_lc_get_base_mat_default() result(res) - implicit none + implicit none class(psb_lc_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_lc_base_mat_default)) then + + if (.not.allocated(psb_lc_base_mat_default)) then allocate(psb_lc_csr_sparse_mat :: psb_lc_base_mat_default) end if res => psb_lc_base_mat_default - + end function psb_lc_get_base_mat_default subroutine psb_lc_clear_mat_default() @@ -2404,7 +2494,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -2412,26 +2502,26 @@ contains ! ! == =================================== - + function psb_lc_sizeof(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_lc_sizeof function psb_lc_get_fmt(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -2441,11 +2531,11 @@ contains function psb_lc_get_dupl(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -2453,11 +2543,11 @@ contains end function psb_lc_get_dupl function psb_lc_get_nrows(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -2466,11 +2556,11 @@ contains end function psb_lc_get_nrows function psb_lc_get_ncols(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -2479,11 +2569,11 @@ contains end function psb_lc_get_ncols function psb_lc_is_triangle(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -2493,11 +2583,11 @@ contains function psb_lc_is_symmetric(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -2506,11 +2596,11 @@ contains end function psb_lc_is_symmetric function psb_lc_is_unit(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2519,11 +2609,11 @@ contains end function psb_lc_is_unit function psb_lc_is_upper(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2532,11 +2622,11 @@ contains end function psb_lc_is_upper function psb_lc_is_lower(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2545,12 +2635,12 @@ contains end function psb_lc_is_lower function psb_lc_is_null(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2558,11 +2648,11 @@ contains end function psb_lc_is_null function psb_lc_is_bld(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2571,11 +2661,11 @@ contains end function psb_lc_is_bld function psb_lc_is_upd(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2584,11 +2674,11 @@ contains end function psb_lc_is_upd function psb_lc_is_asb(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2597,11 +2687,11 @@ contains end function psb_lc_is_asb function psb_lc_is_sorted(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2610,11 +2700,11 @@ contains end function psb_lc_is_sorted function psb_lc_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2623,11 +2713,11 @@ contains end function psb_lc_is_by_rows function psb_lc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2638,61 +2728,61 @@ contains ! subroutine lc_mat_sync(a) - implicit none + implicit none class(psb_lcspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine lc_mat_sync ! subroutine lc_mat_set_host(a) - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine lc_mat_set_host ! subroutine lc_mat_set_dev(a) - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine lc_mat_set_dev ! subroutine lc_mat_set_sync(a) - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine lc_mat_set_sync ! function lc_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function lc_mat_is_dev - + ! function lc_mat_is_host(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2702,11 +2792,11 @@ contains ! function lc_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2717,11 +2807,11 @@ contains function psb_lc_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2729,25 +2819,25 @@ contains end function psb_lc_is_repeatable_updates - subroutine psb_lc_set_repeatable_updates(a,val) - implicit none + subroutine psb_lc_set_repeatable_updates(a,val) + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_lc_set_repeatable_updates function psb_lc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2755,13 +2845,13 @@ contains function psb_lc_get_size(a) result(res) - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2769,23 +2859,23 @@ contains function psb_lc_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_lpk_), intent(in) :: idx class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_lc_get_nz_row subroutine psb_lc_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_lcspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_lc_clean_zeros @@ -2793,7 +2883,7 @@ contains #if defined(IPK4) && defined(LPK8) !!$ subroutine psb_lc_icsgetptn(imin,imax,a,nz,ia,ja,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_lcspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2829,12 +2919,12 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_lc_icsgetptn -!!$ +!!$ !!$ subroutine psb_lc_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_lcspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2870,7 +2960,7 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_lc_icsgetrow #endif diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index b2d224d5b..b4dc43ba7 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_c_vect_mod ! ! This module contains the definition of the psb_c_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_c_vect_mod @@ -43,7 +43,7 @@ module psb_c_vect_mod use psb_i_vect_mod type psb_c_vect_type - class(psb_c_base_vect_type), allocatable :: v + class(psb_c_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => c_vect_get_nrows procedure, pass(x) :: sizeof => c_vect_sizeof @@ -85,7 +85,9 @@ module psb_c_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => c_vect_axpby_v procedure, pass(y) :: axpby_a => c_vect_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => c_vect_axpby_v2 + procedure, pass(z) :: axpby_a2 => c_vect_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 procedure, pass(y) :: mlt_v => c_vect_mlt_v procedure, pass(y) :: mlt_a => c_vect_mlt_a procedure, pass(z) :: mlt_a_2 => c_vect_mlt_a_2 @@ -94,13 +96,37 @@ module psb_c_vect_mod procedure, pass(z) :: mlt_av => c_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => c_vect_div_v + procedure, pass(z) :: div_v2 => c_vect_div_v2 + procedure, pass(x) :: div_v_check => c_vect_div_v_check + procedure, pass(x) :: div_v2_check => c_vect_div_v2_check + procedure, pass(z) :: div_a2 => c_vect_div_a2 + procedure, pass(z) :: div_a2_check => c_vect_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => c_vect_inv_v + procedure, pass(y) :: inv_v_check => c_vect_inv_v_check + procedure, pass(y) :: inv_a2 => c_vect_inv_a2 + procedure, pass(y) :: inv_a2_check => c_vect_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check procedure, pass(x) :: scal => c_vect_scal procedure, pass(x) :: absval1 => c_vect_absval1 procedure, pass(x) :: absval2 => c_vect_absval2 generic, public :: absval => absval1, absval2 - procedure, pass(x) :: nrm2 => c_vect_nrm2 + procedure, pass(x) :: nrm2std => c_vect_nrm2 + procedure, pass(x) :: nrm2weight => c_vect_nrm2_weight + procedure, pass(x) :: nrm2weightmask => c_vect_nrm2_weight_mask + generic, public :: nrm2 => nrm2std, nrm2weight, nrm2weightmask procedure, pass(x) :: amax => c_vect_amax - procedure, pass(x) :: asum => c_vect_asum + procedure, pass(x) :: asum => c_vect_asum + procedure, pass(z) :: acmp_a2 => c_vect_acmp_a2 + procedure, pass(z) :: acmp_v2 => c_vect_acmp_v2 + generic, public :: acmp => acmp_a2, acmp_v2 + procedure, pass(z) :: addconst_a2 => c_vect_addconst_a2 + procedure, pass(z) :: addconst_v2 => c_vect_addconst_v2 + generic, public :: addconst => addconst_a2, addconst_v2 + + end type psb_c_vect_type public :: psb_c_vect @@ -122,8 +148,7 @@ module psb_c_vect_mod private :: c_vect_dot_v, c_vect_dot_a, c_vect_axpby_v, c_vect_axpby_a, & & c_vect_mlt_v, c_vect_mlt_a, c_vect_mlt_a_2, c_vect_mlt_v_2, & & c_vect_mlt_va, c_vect_mlt_av, c_vect_scal, c_vect_absval1, & - & c_vect_absval2, c_vect_nrm2, c_vect_amax, c_vect_asum - + & c_vect_absval2, c_vect_nrm2, c_vect_amax, c_vect_asum class(psb_c_base_vect_type), allocatable, target,& @@ -141,11 +166,11 @@ module psb_c_vect_mod contains - subroutine psb_c_set_vect_default(v) - implicit none + subroutine psb_c_set_vect_default(v) + implicit none class(psb_c_base_vect_type), intent(in) :: v - if (allocated(psb_c_base_vect_default)) then + if (allocated(psb_c_base_vect_default)) then deallocate(psb_c_base_vect_default) end if allocate(psb_c_base_vect_default, mold=v) @@ -153,7 +178,7 @@ contains end subroutine psb_c_set_vect_default function psb_c_get_vect_default(v) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: v class(psb_c_base_vect_type), pointer :: res @@ -171,10 +196,10 @@ contains end subroutine psb_c_clear_vect_default function psb_c_get_base_vect_default() result(res) - implicit none + implicit none class(psb_c_base_vect_type), pointer :: res - if (.not.allocated(psb_c_base_vect_default)) then + if (.not.allocated(psb_c_base_vect_default)) then allocate(psb_c_base_vect_type :: psb_c_base_vect_default) end if @@ -183,14 +208,14 @@ contains end function psb_c_get_base_vect_default subroutine c_vect_clone(x,y,info) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine c_vect_clone @@ -205,7 +230,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) @@ -227,7 +252,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) @@ -247,7 +272,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) @@ -310,7 +335,7 @@ contains end function size_const function c_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -318,7 +343,7 @@ contains end function c_vect_get_nrows function c_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -326,7 +351,7 @@ contains end function c_vect_sizeof function c_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -335,7 +360,7 @@ contains subroutine c_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold @@ -344,12 +369,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_c_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -359,12 +384,12 @@ contains subroutine c_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -374,7 +399,7 @@ contains subroutine c_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -384,7 +409,7 @@ contains subroutine c_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -430,12 +455,12 @@ contains subroutine c_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -444,7 +469,7 @@ contains subroutine c_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -454,7 +479,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -465,7 +490,7 @@ contains subroutine c_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -475,7 +500,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -493,12 +518,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_c_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -509,7 +534,7 @@ contains subroutine c_vect_sync(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -518,7 +543,7 @@ contains end subroutine c_vect_sync subroutine c_vect_set_sync(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -527,7 +552,7 @@ contains end subroutine c_vect_set_sync subroutine c_vect_set_host(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -536,7 +561,7 @@ contains end subroutine c_vect_set_host subroutine c_vect_set_dev(x) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -545,7 +570,7 @@ contains end subroutine c_vect_set_dev function c_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x @@ -556,7 +581,7 @@ contains end function c_vect_is_sync function c_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x @@ -567,11 +592,11 @@ contains end function c_vect_is_host function c_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_c_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -579,7 +604,7 @@ contains function c_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_spk_) :: res @@ -591,7 +616,7 @@ contains end function c_vect_dot_v function c_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -605,14 +630,14 @@ contains subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y complex(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -620,9 +645,27 @@ contains end subroutine c_vect_axpby_v + subroutine c_vect_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine c_vect_axpby_v2 + subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent(in) :: x(:) class(psb_c_vect_type), intent(inout) :: y @@ -634,13 +677,27 @@ contains end subroutine c_vect_axpby_a + subroutine c_vect_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine c_vect_axpby_a2 subroutine c_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -651,7 +708,7 @@ contains subroutine c_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: x(:) class(psb_c_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -667,7 +724,7 @@ contains subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) complex(psb_spk_), intent(in) :: x(:) @@ -675,7 +732,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -683,12 +740,12 @@ contains subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -702,12 +759,12 @@ contains subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: x(:) class(psb_c_vect_type), intent(inout) :: y class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -718,12 +775,12 @@ contains subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(in) :: y(:) class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -733,9 +790,186 @@ contains end subroutine c_vect_mlt_va + subroutine c_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine c_vect_div_v + + subroutine c_vect_div_v2( x, y, z, info) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine c_vect_div_v2 + + subroutine c_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine c_vect_div_v_check + + subroutine c_vect_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine c_vect_div_v2_check + + subroutine c_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine c_vect_div_a2 + + subroutine c_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine c_vect_div_a2_check + + subroutine c_vect_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine c_vect_inv_v + + subroutine c_vect_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine c_vect_inv_v_check + + subroutine c_vect_inv_a2(x, y, info) + use psi_serial_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine c_vect_inv_a2 + + subroutine c_vect_inv_a2_check(x, y, info,flag) + use psi_serial_mod + implicit none + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine c_vect_inv_a2_check + + subroutine c_vect_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine c_vect_acmp_a2 + + subroutine c_vect_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine c_vect_acmp_v2 + subroutine c_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x complex(psb_spk_), intent (in) :: alpha @@ -755,19 +989,19 @@ contains class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine c_vect_absval2 function c_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = szero @@ -775,13 +1009,49 @@ contains end function c_vect_nrm2 + function c_vect_nrm2_weight(n,x,w) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: w + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v)) then + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = szero + end if + + end function c_vect_nrm2_weight + + function c_vect_nrm2_weight_mask(n,x,w,id) result(res) + implicit none + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: w + class(psb_c_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v).and.allocated(id%v)) then + where( abs(id%v%v) <= szero) x%v%v = szero + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = szero + end if + + end function c_vect_nrm2_weight_mask + function c_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = szero @@ -789,13 +1059,14 @@ contains end function c_vect_amax + function c_vect_asum(n,x) result(res) - implicit none + implicit none class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%asum(n) else res = szero @@ -804,6 +1075,35 @@ contains end function c_vect_asum + + subroutine c_vect_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: b + complex(psb_spk_), intent(inout) :: x(:) + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine c_vect_addconst_a2 + + subroutine c_vect_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: b + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine c_vect_addconst_v2 + end module psb_c_vect_mod @@ -818,7 +1118,7 @@ module psb_c_multivect_mod !private type psb_c_multivect_type - class(psb_c_base_multivect_type), allocatable :: v + class(psb_c_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => c_vect_get_nrows procedure, pass(x) :: get_ncols => c_vect_get_ncols @@ -892,11 +1192,11 @@ module psb_c_multivect_mod contains - subroutine psb_c_set_multivect_default(v) - implicit none + subroutine psb_c_set_multivect_default(v) + implicit none class(psb_c_base_multivect_type), intent(in) :: v - if (allocated(psb_c_base_multivect_default)) then + if (allocated(psb_c_base_multivect_default)) then deallocate(psb_c_base_multivect_default) end if allocate(psb_c_base_multivect_default, mold=v) @@ -904,7 +1204,7 @@ contains end subroutine psb_c_set_multivect_default function psb_c_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: v class(psb_c_base_multivect_type), pointer :: res @@ -914,10 +1214,10 @@ contains function psb_c_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_c_base_multivect_type), pointer :: res - if (.not.allocated(psb_c_base_multivect_default)) then + if (.not.allocated(psb_c_base_multivect_default)) then allocate(psb_c_base_multivect_type :: psb_c_base_multivect_default) end if @@ -927,14 +1227,14 @@ contains subroutine c_vect_clone(x,y,info) - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x class(psb_c_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine c_vect_clone @@ -947,7 +1247,7 @@ contains class(psb_c_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) @@ -965,7 +1265,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) @@ -1025,7 +1325,7 @@ contains end function size_const function c_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1033,7 +1333,7 @@ contains end function c_vect_get_nrows function c_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1041,7 +1341,7 @@ contains end function c_vect_get_ncols function c_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1049,7 +1349,7 @@ contains end function c_vect_sizeof function c_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_c_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1058,18 +1358,18 @@ contains subroutine c_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(out) :: x class(psb_c_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_c_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1079,12 +1379,12 @@ contains subroutine c_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1094,7 +1394,7 @@ contains subroutine c_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1104,7 +1404,7 @@ contains subroutine c_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1115,7 +1415,7 @@ contains end subroutine c_vect_asb subroutine c_vect_sync(x) - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1183,12 +1483,12 @@ contains subroutine c_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1197,7 +1497,7 @@ contains subroutine c_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_c_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1207,7 +1507,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1223,12 +1523,12 @@ contains class(psb_c_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_c_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1238,7 +1538,7 @@ contains !!$ function c_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_spk_) :: res @@ -1250,28 +1550,28 @@ contains !!$ end function c_vect_dot_v !!$ !!$ function c_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ complex(psb_spk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_spk_) :: res -!!$ +!!$ !!$ res = czero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function c_vect_dot_a -!!$ +!!$ !!$ subroutine c_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ complex(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1281,25 +1581,25 @@ contains !!$ !!$ subroutine c_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ complex(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine c_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine c_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1310,7 +1610,7 @@ contains !!$ !!$ subroutine c_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1320,13 +1620,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine c_vect_mlt_a !!$ !!$ !!$ subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: y(:) !!$ complex(psb_spk_), intent(in) :: x(:) @@ -1334,20 +1634,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine c_vect_mlt_a_2 !!$ !!$ subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ class(psb_c_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1361,12 +1661,12 @@ contains !!$ !!$ subroutine c_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: x(:) !!$ class(psb_c_multivect_type), intent(inout) :: y !!$ class(psb_c_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1377,16 +1677,16 @@ contains !!$ !!$ subroutine c_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_spk_), intent(in) :: alpha,beta !!$ complex(psb_spk_), intent(in) :: y(:) !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ class(psb_c_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1394,36 +1694,36 @@ contains !!$ !!$ subroutine c_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ complex(psb_spk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine c_vect_scal !!$ !!$ !!$ function c_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = szero !!$ end if !!$ !!$ end function c_vect_nrm2 -!!$ +!!$ !!$ function c_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = szero @@ -1432,12 +1732,12 @@ contains !!$ end function c_vect_amax !!$ !!$ function c_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_c_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = szero diff --git a/base/modules/serial/psb_d_base_mat_mod.F90 b/base/modules/serial/psb_d_base_mat_mod.F90 index 92ffaeb15..a6ff7c5ec 100644 --- a/base/modules/serial/psb_d_base_mat_mod.F90 +++ b/base/modules/serial/psb_d_base_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,12 +27,12 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! module psb_d_base_mat_mod - + use psb_base_mat_mod use psb_d_base_vect_mod @@ -56,59 +56,59 @@ module psb_d_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_d_base_csput_a - procedure, pass(a) :: csput_v => psb_d_base_csput_v + procedure, pass(a) :: csput_v => psb_d_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_d_base_csgetrow procedure, pass(a) :: csgetblk => psb_d_base_csgetblk procedure, pass(a) :: get_diag => psb_d_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_d_base_tril procedure, pass(a) :: triu => psb_d_base_triu - procedure, pass(a) :: csclip => psb_d_base_csclip - procedure, pass(a) :: cp_to_coo => psb_d_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_d_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_d_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_d_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_d_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_d_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_d_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_d_base_mv_from_fmt - procedure, pass(a) :: mold => psb_d_base_mold + procedure, pass(a) :: csclip => psb_d_base_csclip + procedure, pass(a) :: cp_to_coo => psb_d_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_d_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_d_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_d_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_d_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_d_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_d_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_d_base_mv_from_fmt + procedure, pass(a) :: mold => psb_d_base_mold procedure, pass(a) :: clone => psb_d_base_clone procedure, pass(a) :: make_nonunit => psb_d_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_d_base_clean_zeros ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_d_base_cp_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_d_base_cp_from_lcoo - procedure, pass(a) :: cp_to_lfmt => psb_d_base_cp_to_lfmt - procedure, pass(a) :: cp_from_lfmt => psb_d_base_cp_from_lfmt - procedure, pass(a) :: mv_to_lcoo => psb_d_base_mv_to_lcoo - procedure, pass(a) :: mv_from_lcoo => psb_d_base_mv_from_lcoo - procedure, pass(a) :: mv_to_lfmt => psb_d_base_mv_to_lfmt - procedure, pass(a) :: mv_from_lfmt => psb_d_base_mv_from_lfmt + procedure, pass(a) :: cp_to_lcoo => psb_d_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_d_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_d_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_d_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_d_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_d_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_d_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_d_base_mv_from_lfmt + - ! - ! Transpose methods: defined here but not implemented. - ! + ! Transpose methods: defined here but not implemented. + ! procedure, pass(a) :: transp_1mat => psb_d_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_d_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_d_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_d_base_transc_2mat - + + ! + ! Computational methods: defined here but not implemented. ! - ! Computational methods: defined here but not implemented. - ! procedure, pass(a) :: vect_mv => psb_d_base_vect_mv procedure, pass(a) :: csmv => psb_d_base_csmv procedure, pass(a) :: csmm => psb_d_base_csmm generic, public :: spmm => csmm, csmv, vect_mv procedure, pass(a) :: in_vect_sv => psb_d_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_d_base_inner_cssv + procedure, pass(a) :: inner_cssv => psb_d_base_inner_cssv procedure, pass(a) :: inner_cssm => psb_d_base_inner_cssm generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv procedure, pass(a) :: vect_cssv => psb_d_base_vect_cssv @@ -125,15 +125,20 @@ module psb_d_base_mat_mod procedure, pass(a) :: arwsum => psb_d_base_arwsum procedure, pass(a) :: colsum => psb_d_base_colsum procedure, pass(a) :: aclsum => psb_d_base_aclsum + procedure, pass(a) :: scalpid => psb_d_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_d_base_spaxpby + procedure, pass(a) :: cmpval => psb_d_base_cmpval + procedure, pass(a) :: cmpmat => psb_d_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_d_base_sparse_mat - + private :: d_base_mat_sync, d_base_mat_is_host, d_base_mat_is_dev, & & d_base_mat_is_sync, d_base_mat_set_host, d_base_mat_set_dev,& & d_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_d_coo_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat - !! + !! !! psb_d_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -147,15 +152,15 @@ module psb_d_base_mat_mod integer(psb_ipk_), allocatable :: ia(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_dpk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => d_coo_get_size procedure, pass(a) :: get_nzeros => d_coo_get_nzeros procedure, nopass :: get_fmt => d_coo_get_fmt @@ -175,9 +180,9 @@ module psb_d_base_mat_mod ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_d_cp_coo_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_d_cp_coo_from_lcoo - + procedure, pass(a) :: cp_to_lcoo => psb_d_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_d_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_d_coo_csput_a procedure, pass(a) :: get_diag => psb_d_coo_get_diag procedure, pass(a) :: csgetrow => psb_d_coo_csgetrow @@ -203,18 +208,18 @@ module psb_d_base_mat_mod ! This is COO specific ! procedure, pass(a) :: set_nzeros => d_coo_set_nzeros - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => d_coo_transp_1mat procedure, pass(a) :: transc_1mat => d_coo_transc_1mat ! - ! Computational methods. - ! + ! Computational methods. + ! procedure, pass(a) :: csmm => psb_d_coo_csmm procedure, pass(a) :: csmv => psb_d_coo_csmv procedure, pass(a) :: inner_cssm => psb_d_coo_cssm @@ -228,14 +233,17 @@ module psb_d_base_mat_mod procedure, pass(a) :: arwsum => psb_d_coo_arwsum procedure, pass(a) :: colsum => psb_d_coo_colsum procedure, pass(a) :: aclsum => psb_d_coo_aclsum - + procedure, pass(a) :: scalpid => psb_d_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_d_coo_spaxpby + procedure, pass(a) :: cmpval => psb_d_coo_cmpval + procedure, pass(a) :: cmpmat => psb_d_coo_cmpmat end type psb_d_coo_sparse_mat - + private :: d_coo_get_nzeros, d_coo_set_nzeros, & & d_coo_get_fmt, d_coo_free, d_coo_sizeof, & & d_coo_transp_1mat, d_coo_transc_1mat - - + + !> \namespace psb_base_mod \class psb_ld_base_sparse_mat !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat !! The psb_ld_base_sparse_mat type, extending psb_base_sparse_mat, @@ -255,33 +263,33 @@ module psb_d_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_ld_base_csput_a - procedure, pass(a) :: csput_v => psb_ld_base_csput_v + procedure, pass(a) :: csput_v => psb_ld_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_ld_base_csgetrow procedure, pass(a) :: csgetblk => psb_ld_base_csgetblk procedure, pass(a) :: get_diag => psb_ld_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_ld_base_tril procedure, pass(a) :: triu => psb_ld_base_triu - procedure, pass(a) :: csclip => psb_ld_base_csclip - procedure, pass(a) :: cp_to_coo => psb_ld_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_ld_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_ld_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_ld_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_ld_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_ld_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_ld_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_ld_base_mv_from_fmt - procedure, pass(a) :: mold => psb_ld_base_mold + procedure, pass(a) :: csclip => psb_ld_base_csclip + procedure, pass(a) :: cp_to_coo => psb_ld_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_ld_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ld_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ld_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ld_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_ld_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ld_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ld_base_mv_from_fmt + procedure, pass(a) :: mold => psb_ld_base_mold procedure, pass(a) :: clone => psb_ld_base_clone procedure, pass(a) :: make_nonunit => psb_ld_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_ld_base_clean_zeros ! - ! Computational methods: defined here but not implemented. - ! + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_ld_base_scals procedure, pass(a) :: scalv => psb_ld_base_scal generic, public :: scal => scals, scalv @@ -292,35 +300,40 @@ module psb_d_base_mat_mod procedure, pass(a) :: arwsum => psb_ld_base_arwsum procedure, pass(a) :: colsum => psb_ld_base_colsum procedure, pass(a) :: aclsum => psb_ld_base_aclsum + procedure, pass(a) :: scalpid => psb_ld_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_ld_base_spaxpby + procedure, pass(a) :: cmpval => psb_ld_base_cmpval + procedure, pass(a) :: cmpmat => psb_ld_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_icoo => psb_ld_base_cp_to_icoo - procedure, pass(a) :: cp_from_icoo => psb_ld_base_cp_from_icoo - procedure, pass(a) :: cp_to_ifmt => psb_ld_base_cp_to_ifmt - procedure, pass(a) :: cp_from_ifmt => psb_ld_base_cp_from_ifmt - procedure, pass(a) :: mv_to_icoo => psb_ld_base_mv_to_icoo - procedure, pass(a) :: mv_from_icoo => psb_ld_base_mv_from_icoo - procedure, pass(a) :: mv_to_ifmt => psb_ld_base_mv_to_ifmt - procedure, pass(a) :: mv_from_ifmt => psb_ld_base_mv_from_ifmt - + procedure, pass(a) :: cp_to_icoo => psb_ld_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_ld_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_ld_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_ld_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_ld_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_ld_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_ld_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_ld_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. ! - ! Transpose methods: defined here but not implemented. - ! procedure, pass(a) :: transp_1mat => psb_ld_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_ld_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_ld_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_ld_base_transc_2mat - + end type psb_ld_base_sparse_mat - + private :: ld_base_mat_sync, ld_base_mat_is_host, ld_base_mat_is_dev, & & ld_base_mat_is_sync, ld_base_mat_set_host, ld_base_mat_set_dev,& & ld_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_ld_coo_sparse_mat !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat - !! + !! !! psb_ld_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -334,15 +347,15 @@ module psb_d_base_mat_mod integer(psb_lpk_), allocatable :: ia(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_dpk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => ld_coo_get_size procedure, pass(a) :: get_nzeros => ld_coo_get_nzeros procedure, nopass :: get_fmt => ld_coo_get_fmt @@ -360,7 +373,7 @@ module psb_d_base_mat_mod procedure, pass(a) :: mv_from_fmt => psb_ld_mv_coo_from_fmt procedure, pass(a) :: cp_to_icoo => psb_ld_cp_coo_to_icoo procedure, pass(a) :: cp_from_icoo => psb_ld_cp_coo_from_icoo - + procedure, pass(a) :: csput_a => psb_ld_coo_csput_a procedure, pass(a) :: get_diag => psb_ld_coo_get_diag procedure, pass(a) :: csgetrow => psb_ld_coo_csgetrow @@ -382,9 +395,9 @@ module psb_d_base_mat_mod procedure, pass(a) :: set_sort_status => ld_coo_set_sort_status procedure, pass(a) :: get_sort_status => ld_coo_get_sort_status - - ! Computational methods: defined here but not implemented. - ! + + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_ld_coo_scals procedure, pass(a) :: scalv => psb_ld_coo_scal procedure, pass(a) :: maxval => psb_ld_coo_maxval @@ -394,7 +407,10 @@ module psb_d_base_mat_mod procedure, pass(a) :: arwsum => psb_ld_coo_arwsum procedure, pass(a) :: colsum => psb_ld_coo_colsum procedure, pass(a) :: aclsum => psb_ld_coo_aclsum - + procedure, pass(a) :: scalpid => psb_ld_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_ld_coo_spaxpby + procedure, pass(a) :: cmpval => psb_ld_coo_cmpval + procedure, pass(a) :: cmpmat => psb_ld_coo_cmpmat ! ! This is COO specific ! @@ -406,25 +422,25 @@ module psb_d_base_mat_mod procedure, pass(a) :: iset_nzeros => ld_coo_iset_nzeros generic, public :: set_nzeros => iset_nzeros #endif - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => ld_coo_transp_1mat procedure, pass(a) :: transc_1mat => ld_coo_transc_1mat - + end type psb_ld_coo_sparse_mat - + private :: ld_coo_get_nzeros, ld_coo_iset_nzeros, & & ld_coo_get_fmt, ld_coo_free, ld_coo_sizeof, & & ld_coo_transp_1mat, ld_coo_transc_1mat #if defined(IPK4) && defined(LPK8) private :: ld_coo_lset_nzeros #endif - + ! == ================= ! ! BASE interfaces @@ -433,14 +449,14 @@ module psb_d_base_mat_mod !> Function csput: !! \memberof psb_d_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -453,33 +469,33 @@ module psb_d_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_csput_a end interface - - interface - subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -487,43 +503,43 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_d_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_d_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -536,33 +552,33 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_d_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_d_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -573,34 +589,34 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_d_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_d_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -621,27 +637,27 @@ module psb_d_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_d_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -650,13 +666,13 @@ module psb_d_base_mat_mod class(psb_d_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_d_base_tril end interface - + ! !> Function triu: !! \memberof psb_d_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -665,27 +681,27 @@ module psb_d_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_d_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -694,27 +710,27 @@ module psb_d_base_mat_mod class(psb_d_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_d_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_d_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_d_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_d_base_get_diag(a,d,info) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_d_base_sparse_mat @@ -724,10 +740,10 @@ module psb_d_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mold(a,b,info) - import + ! + interface + subroutine psb_d_base_mold(a,b,info) + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -739,21 +755,21 @@ module psb_d_base_mat_mod !> Function clone: !! \memberof psb_d_base_sparse_mat !! \brief Allocate and clone a class(psb_d_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_d_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_clone end interface @@ -763,18 +779,18 @@ module psb_d_base_mat_mod !> Function make_nonunit: !! \memberof psb_d_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_d_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a end subroutine psb_d_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_d_base_sparse_mat @@ -782,16 +798,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_to_coo(a,b,info) + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_d_base_sparse_mat @@ -799,16 +815,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_from_coo(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_d_base_sparse_mat @@ -817,16 +833,16 @@ module psb_d_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_to_fmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_d_base_sparse_mat @@ -835,16 +851,16 @@ module psb_d_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_from_fmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_d_base_sparse_mat @@ -852,16 +868,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_to_coo(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_d_base_sparse_mat @@ -869,16 +885,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_from_coo(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_d_base_sparse_mat @@ -887,16 +903,16 @@ module psb_d_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_to_fmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_d_base_sparse_mat @@ -905,10 +921,10 @@ module psb_d_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_from_fmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -921,16 +937,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_to_lcoo(a,b,info) + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_to_lcoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_d_base_sparse_mat @@ -938,16 +954,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_from_lcoo(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_from_lcoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_d_base_sparse_mat @@ -956,16 +972,16 @@ module psb_d_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_to_lfmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_to_lfmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_d_base_sparse_mat @@ -974,16 +990,16 @@ module psb_d_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_cp_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_d_base_cp_from_lfmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_cp_from_lfmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_d_base_sparse_mat @@ -991,16 +1007,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_to_lcoo(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_to_lcoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_d_base_sparse_mat @@ -1008,16 +1024,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_from_lcoo(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_from_lcoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_d_base_sparse_mat @@ -1026,16 +1042,16 @@ module psb_d_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_to_lfmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_to_lfmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_d_base_sparse_mat @@ -1044,10 +1060,10 @@ module psb_d_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_d_base_mv_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_d_base_mv_from_lfmt(a,b,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1056,78 +1072,78 @@ module psb_d_base_mat_mod ! - !> + !> !! \memberof psb_d_base_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_clean_zeros ! interface subroutine psb_d_base_clean_zeros(a, info) - import + import class(psb_d_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_clean_zeros end interface - + ! !> Function transp: !! \memberof psb_d_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_d_base_transp_2mat(a,b) - import + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_d_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_d_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_d_base_transc_2mat(a,b) - import + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_d_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_d_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_d_base_transp_1mat(a) - import + import class(psb_d_base_sparse_mat), intent(inout) :: a end subroutine psb_d_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_d_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_d_base_transc_1mat(a) - import + import class(psb_d_base_sparse_mat), intent(inout) :: a end subroutine psb_d_base_transc_1mat end interface - + ! !> Function csmm: !! \memberof psb_d_base_sparse_mat @@ -1146,9 +1162,9 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! ! - interface + interface subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1156,7 +1172,7 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_base_csmm end interface - + !> Function csmv: !! \memberof psb_d_base_sparse_mat !! \brief Product by a dense rank 1 array. @@ -1174,9 +1190,9 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1184,7 +1200,7 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_base_csmv end interface - + !> Function vect_mv: !! \memberof psb_d_base_sparse_mat !! \brief Product by an encapsulated array type(psb_d_vect_type) @@ -1196,7 +1212,7 @@ module psb_d_base_mat_mod !! versions with the standard arrays. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1209,9 +1225,9 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x @@ -1220,7 +1236,7 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_base_vect_mv end interface - + ! !> Function cssm: !! \memberof psb_d_base_sparse_mat @@ -1229,7 +1245,7 @@ module psb_d_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssm. + !! Internal workhorse called by cssm. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1241,9 +1257,9 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1251,8 +1267,8 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_base_inner_cssm end interface - - + + ! !> Function cssv: !! \memberof psb_d_base_sparse_mat @@ -1261,7 +1277,7 @@ module psb_d_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssv. + !! Internal workhorse called by cssv. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1273,12 +1289,12 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface - subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1286,7 +1302,7 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_base_inner_cssv end interface - + ! !> Function inner_vect_cssv: !! \memberof psb_d_base_sparse_mat @@ -1296,10 +1312,10 @@ module psb_d_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by vect_cssv. + !! Internal workhorse called by vect_cssv. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1311,9 +1327,9 @@ module psb_d_base_mat_mod !! \param trans [N] Whether to use A (N), its transpose (T) !! or its conjugate transpose (C) ! - interface - subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x, y @@ -1321,7 +1337,7 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_base_inner_vect_sv end interface - + ! !> Function cssm: !! \memberof psb_d_base_sparse_mat @@ -1340,12 +1356,12 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1354,7 +1370,7 @@ module psb_d_base_mat_mod real(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_d_base_cssm end interface - + ! !> Function cssv: !! \memberof psb_d_base_sparse_mat @@ -1373,12 +1389,12 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1387,7 +1403,7 @@ module psb_d_base_mat_mod real(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_d_base_cssv end interface - + ! !> Function vect_cssv: !! \memberof psb_d_base_sparse_mat @@ -1407,12 +1423,12 @@ module psb_d_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. + !! \param D [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x,y @@ -1421,24 +1437,24 @@ module psb_d_base_mat_mod class(psb_d_base_vect_type), optional, intent(inout) :: d end subroutine psb_d_base_vect_cssv end interface - + ! !> Function base_scals: !! \memberof psb_d_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_d_base_scals(d,a,info) - import + interface + subroutine psb_d_base_scals(d,a,info) + import class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_scals end interface - + ! !> Function base_scal: !! \memberof psb_d_base_sparse_mat @@ -1448,40 +1464,125 @@ module psb_d_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_d_base_scal(d,a,info,side) - import + interface + subroutine psb_d_base_scal(d,a,info,side) + import class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_d_base_scal end interface - + + ! + !> Function base_scalplusidentity: + !! \memberof psb_d_base_sparse_mat + !! \brief Scale a matrix by a vector and sums an identity + !! + !! \param d Scaling + !! \param info return code + ! + interface + subroutine psb_d_base_scalplusidentity(d,a,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_scalplusidentity + end interface + + ! + !> Function base_spaxpby: + !! \memberof psb_d_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_d_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_spaxpby + end interface + + ! + !> Function base_cmpval: + !! \memberof psb_d_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_d_base_cmpval(a,val,tol,info) result(res) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_d_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_d_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_d_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_d_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_d_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_d_base_maxval(a) result(res) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_d_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_d_base_csnmi(a) result(res) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_base_csnmi @@ -1492,11 +1593,11 @@ module psb_d_base_mat_mod !> Function base_csnmi: !! \memberof psb_d_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_d_base_csnm1(a) result(res) - import + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_base_csnm1 @@ -1508,11 +1609,11 @@ module psb_d_base_mat_mod !! \memberof psb_d_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_d_base_rowsum(d,a) - import + interface + subroutine psb_d_base_rowsum(d,a) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_rowsum @@ -1523,26 +1624,26 @@ module psb_d_base_mat_mod !! \memberof psb_d_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_d_base_arwsum(d,a) - import + !! + interface + subroutine psb_d_base_arwsum(d,a) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_d_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_d_base_colsum(d,a) - import + interface + subroutine psb_d_base_colsum(d,a) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_colsum @@ -1553,16 +1654,16 @@ module psb_d_base_mat_mod !! \memberof psb_d_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_d_base_aclsum(d,a) - import + !! + interface + subroutine psb_d_base_aclsum(d,a) + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_aclsum end interface - + ! == =============== ! ! COO interfaces @@ -1570,76 +1671,76 @@ module psb_d_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_d_coo_reallocate_nz(nz,a) - import + subroutine psb_d_coo_reallocate_nz(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a end subroutine psb_d_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_d_coo_sparse_mat ! interface - subroutine psb_d_coo_ensure_size(nz,a) - import + subroutine psb_d_coo_ensure_size(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a end subroutine psb_d_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_d_coo_reinit(a,clear) - import - class(psb_d_coo_sparse_mat), intent(inout) :: a + import + class(psb_d_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_coo_reinit end interface ! - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_d_coo_trim(a) - import + import class(psb_d_coo_sparse_mat), intent(inout) :: a end subroutine psb_d_coo_trim end interface ! - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_clean_zeros ! interface subroutine psb_d_coo_clean_zeros(a,info) - import + import class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_clean_zeros end interface ! - !> + !> !! \memberof psb_d_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_d_coo_clean_negidx(a,info) - import + import class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_clean_negidx @@ -1655,11 +1756,11 @@ module psb_d_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) @@ -1668,34 +1769,34 @@ module psb_d_base_mat_mod end subroutine psb_d_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner - + ! - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_ipk_), intent(in) :: m,n class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_d_coo_allocate_mnnz end interface - + !> \memberof psb_d_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_d_coo_mold(a,b,info) - import + interface + subroutine psb_d_coo_mold(a,b,info) + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_d_coo_sparse_mat @@ -1710,17 +1811,17 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_d_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_d_coo_sparse_mat @@ -1729,16 +1830,16 @@ module psb_d_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_d_coo_get_nz_row(idx,a) result(res) - import + import class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res end function psb_d_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -1750,12 +1851,12 @@ module psb_d_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) @@ -1764,162 +1865,162 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_d_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_d_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_d_fix_coo(a,info,idir) - import + interface + subroutine psb_d_fix_coo(a,info,idir) + import class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_d_fix_coo end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo - interface - subroutine psb_d_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_d_cp_coo_to_coo(a,b,info) + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo - interface - subroutine psb_d_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_d_cp_coo_from_coo(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_from_coo end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo - interface - subroutine psb_d_cp_coo_to_lcoo(a,b,info) - import + interface + subroutine psb_d_cp_coo_to_lcoo(a,b,info) + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_to_lcoo end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo - interface - subroutine psb_d_cp_coo_from_lcoo(a,b,info) - import + interface + subroutine psb_d_cp_coo_from_lcoo(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_from_lcoo end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo - !! - interface - subroutine psb_d_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_d_cp_coo_to_fmt(a,b,info) + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_fmt - !! - interface - subroutine psb_d_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_d_cp_coo_from_fmt(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_to_coo - interface - subroutine psb_d_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_d_mv_coo_to_coo(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo - interface - subroutine psb_d_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_d_mv_coo_from_coo(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_to_fmt - interface - subroutine psb_d_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_d_mv_coo_to_fmt(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt - interface - subroutine psb_d_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_d_mv_coo_from_fmt(a,b,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_d_coo_cp_from(a,b) - import + import class(psb_d_coo_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat), intent(in) :: b end subroutine psb_d_coo_cp_from end interface - - interface + + interface subroutine psb_d_coo_mv_from(a,b) - import + import class(psb_d_coo_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat), intent(inout) :: b end subroutine psb_d_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_d_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -1936,9 +2037,9 @@ module psb_d_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1946,14 +2047,14 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_csput_a end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1965,14 +2066,14 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_coo_csgetptn end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csgetrow - interface + interface subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1985,13 +2086,13 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_coo_csgetrow end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssv - interface - subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1999,12 +2100,12 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_coo_cssv end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssm - interface - subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -2012,13 +2113,13 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_coo_cssm end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csmv - interface - subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -2027,12 +2128,12 @@ module psb_d_base_mat_mod end subroutine psb_d_coo_csmv end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csmm - interface - subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -2040,121 +2141,173 @@ module psb_d_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_coo_csmm end interface - - - !> + + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_maxval - interface + interface function psb_d_coo_maxval(a) result(res) - import + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_coo_maxval end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csnmi - interface + interface function psb_d_coo_csnmi(a) result(res) - import + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_coo_csnmi end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csnm1 - interface + interface function psb_d_coo_csnm1(a) result(res) - import + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_coo_csnm1 end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_rowsum - interface - subroutine psb_d_coo_rowsum(d,a) - import + interface + subroutine psb_d_coo_rowsum(d,a) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_rowsum end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_arwsum - interface - subroutine psb_d_coo_arwsum(d,a) - import + interface + subroutine psb_d_coo_arwsum(d,a) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_arwsum end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_colsum - interface - subroutine psb_d_coo_colsum(d,a) - import + interface + subroutine psb_d_coo_colsum(d,a) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_colsum end interface - !> + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_aclsum - interface - subroutine psb_d_coo_aclsum(d,a) - import + interface + subroutine psb_d_coo_aclsum(d,a) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_aclsum end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_get_diag - interface - subroutine psb_d_coo_get_diag(a,d,info) - import + interface + subroutine psb_d_coo_get_diag(a,d,info) + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_get_diag end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scal - interface - subroutine psb_d_coo_scal(d,a,info,side) - import + interface + subroutine psb_d_coo_scal(d,a,info,side) + import class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_d_coo_scal end interface - - !> + + !> !! \memberof psb_d_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scals interface - subroutine psb_d_coo_scals(d,a,info) - import + subroutine psb_d_coo_scals(d,a,info) + import class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_scals end interface - + !> + !! \memberof psb_d_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_scalplusidentity + interface + subroutine psb_d_coo_scalplusidentity(d,a,info) + import + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_coo_scalplusidentity + end interface + ! + !! \memberof psb_d_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_spaxpby + interface + subroutine psb_d_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_coo_spaxpby + end interface + + ! + !! \memberof psb_d_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_cmpval + interface + function psb_d_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_d_coo_cmpval + end interface + + ! + !! \memberof psb_d_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_cmpmat + interface + function psb_d_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_d_coo_cmpmat + end interface + ! == ================= ! ! BASE interfaces @@ -2163,14 +2316,14 @@ module psb_d_base_mat_mod !> Function csput: !! \memberof psb_ld_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -2183,33 +2336,33 @@ module psb_d_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_csput_a end interface - - interface - subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2217,43 +2370,43 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_ld_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -2266,33 +2419,33 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_ld_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_ld_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_lpk_), intent(in) :: imin,imax @@ -2303,34 +2456,34 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_ld_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_ld_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -2351,27 +2504,27 @@ module psb_d_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ld_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -2380,13 +2533,13 @@ module psb_d_base_mat_mod class(psb_ld_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_ld_base_tril end interface - + ! !> Function triu: !! \memberof psb_ld_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -2395,27 +2548,27 @@ module psb_d_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ld_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -2424,27 +2577,27 @@ module psb_d_base_mat_mod class(psb_ld_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_ld_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_ld_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_ld_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_ld_base_get_diag(a,d,info) + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_ld_base_sparse_mat @@ -2454,10 +2607,10 @@ module psb_d_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mold(a,b,info) - import + ! + interface + subroutine psb_ld_base_mold(a,b,info) + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2469,21 +2622,21 @@ module psb_d_base_mat_mod !> Function clone: !! \memberof psb_ld_base_sparse_mat !! \brief Allocate and clone a class(psb_ld_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_ld_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_clone end interface @@ -2493,18 +2646,18 @@ module psb_d_base_mat_mod !> Function make_nonunit: !! \memberof psb_ld_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_ld_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a end subroutine psb_ld_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_ld_base_sparse_mat @@ -2512,16 +2665,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_to_coo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_ld_base_sparse_mat @@ -2529,16 +2682,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_from_coo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2547,16 +2700,16 @@ module psb_d_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_to_fmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2565,16 +2718,16 @@ module psb_d_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_from_fmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_ld_base_sparse_mat @@ -2582,16 +2735,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_to_coo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_ld_base_sparse_mat @@ -2599,16 +2752,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_from_coo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2617,16 +2770,16 @@ module psb_d_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_to_fmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2635,17 +2788,17 @@ module psb_d_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_from_fmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_from_fmt end interface - + ! !> Function cp_to_coo: !! \memberof psb_ld_base_sparse_mat @@ -2653,16 +2806,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_to_icoo(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_to_icoo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_to_icoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_ld_base_sparse_mat @@ -2670,16 +2823,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_from_icoo(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_from_icoo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_from_icoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2688,16 +2841,16 @@ module psb_d_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_to_ifmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_to_ifmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2706,16 +2859,16 @@ module psb_d_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_cp_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_cp_from_ifmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_cp_from_ifmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_ld_base_sparse_mat @@ -2723,16 +2876,16 @@ module psb_d_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_to_icoo(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_to_icoo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_to_icoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_ld_base_sparse_mat @@ -2740,16 +2893,16 @@ module psb_d_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_from_icoo(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_from_icoo(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_from_icoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2758,16 +2911,16 @@ module psb_d_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_to_ifmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_mv_to_ifmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_ld_base_sparse_mat @@ -2776,10 +2929,10 @@ module psb_d_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ld_base_mv_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_ld_base_mv_from_ifmt(a,b,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2789,111 +2942,150 @@ module psb_d_base_mat_mod ! - !> + !> !! \memberof psb_ld_base_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros ! interface subroutine psb_ld_base_clean_zeros(a, info) - import + import class(psb_ld_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_clean_zeros end interface - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_maxval - interface + interface function psb_ld_coo_maxval(a) result(res) - import + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_coo_maxval end interface - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_csnmi - interface + interface function psb_ld_coo_csnmi(a) result(res) - import + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_coo_csnmi end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_csnm1 - interface + interface function psb_ld_coo_csnm1(a) result(res) - import + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_coo_csnm1 end interface - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_coo_rowsum(d,a) - import + interface + subroutine psb_ld_coo_rowsum(d,a) + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_coo_rowsum end interface - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_coo_arwsum(d,a) - import + interface + subroutine psb_ld_coo_arwsum(d,a) + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_coo_arwsum end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_coo_colsum(d,a) - import + interface + subroutine psb_ld_coo_colsum(d,a) + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_coo_colsum end interface - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_coo_aclsum(d,a) - import + interface + subroutine psb_ld_coo_aclsum(d,a) + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_coo_aclsum end interface - + ! !> Function base_scals: !! \memberof psb_ld_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_ld_base_scals(d,a,info) - import + interface + subroutine psb_ld_base_scals(d,a,info) + import class(psb_ld_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_base_scals end interface - + + ! + !> Function base_scalsplusidentity: + !! \memberof psb_ld_base_sparse_mat + !! \brief Scale a matrix by a single scalar value and adds identity + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_ld_base_scalplusidentity(d,a,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_scalplusidentity + end interface + ! + !> Function base_spaxpby: + !! \memberof psb_ld_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_ld_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_spaxpby + end interface + + ! !> Function base_scal: !! \memberof psb_ld_base_sparse_mat @@ -2903,40 +3095,86 @@ module psb_d_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_ld_base_scal(d,a,info,side) - import + interface + subroutine psb_ld_base_scal(d,a,info,side) + import class(psb_ld_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_ld_base_scal end interface - + + ! + !> Function base_cmpval: + !! \memberof psb_ld_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_ld_base_cmpval(a,val,tol,info) result(res) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ld_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_ld_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_ld_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ld_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_ld_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_ld_base_maxval(a) result(res) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_ld_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_ld_base_csnmi(a) result(res) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_base_csnmi @@ -2947,11 +3185,11 @@ module psb_d_base_mat_mod !> Function base_csnmi: !! \memberof psb_ld_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_ld_base_csnm1(a) result(res) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_base_csnm1 @@ -2963,11 +3201,11 @@ module psb_d_base_mat_mod !! \memberof psb_ld_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_ld_base_rowsum(d,a) - import + interface + subroutine psb_ld_base_rowsum(d,a) + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_base_rowsum @@ -2978,26 +3216,26 @@ module psb_d_base_mat_mod !! \memberof psb_ld_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_ld_base_arwsum(d,a) - import + !! + interface + subroutine psb_ld_base_arwsum(d,a) + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_ld_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_ld_base_colsum(d,a) - import + interface + subroutine psb_ld_base_colsum(d,a) + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_base_colsum @@ -3008,76 +3246,76 @@ module psb_d_base_mat_mod !! \memberof psb_ld_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_ld_base_aclsum(d,a) - import + !! + interface + subroutine psb_ld_base_aclsum(d,a) + import class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_base_aclsum end interface - + ! !> Function transp: !! \memberof psb_ld_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_ld_base_transp_2mat(a,b) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_ld_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_ld_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_ld_base_transc_2mat(a,b) - import + import class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_ld_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_ld_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_ld_base_transp_1mat(a) - import + import class(psb_ld_base_sparse_mat), intent(inout) :: a end subroutine psb_ld_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_ld_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_ld_base_transc_1mat(a) - import + import class(psb_ld_base_sparse_mat), intent(inout) :: a end subroutine psb_ld_base_transc_1mat end interface - + ! == =============== ! ! COO interfaces @@ -3085,82 +3323,82 @@ module psb_d_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_ld_coo_reallocate_nz(nz,a) - import + subroutine psb_ld_coo_reallocate_nz(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_ld_coo_sparse_mat), intent(inout) :: a end subroutine psb_ld_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_ld_coo_sparse_mat ! interface - subroutine psb_ld_coo_ensure_size(nz,a) - import + subroutine psb_ld_coo_ensure_size(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_ld_coo_sparse_mat), intent(inout) :: a end subroutine psb_ld_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_ld_coo_reinit(a,clear) - import - class(psb_ld_coo_sparse_mat), intent(inout) :: a + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ld_coo_reinit end interface ! - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_ld_coo_trim(a) - import + import class(psb_ld_coo_sparse_mat), intent(inout) :: a end subroutine psb_ld_coo_trim end interface ! - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros ! interface subroutine psb_ld_coo_clean_zeros(a,info) - import + import class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_coo_clean_zeros end interface - + ! - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_ld_coo_clean_negidx(a,info) - import + import class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_coo_clean_negidx end interface -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) ! !> Funtion: coo_clean_negidx_inner !! \brief Take out any entries with negative row or column index @@ -3171,11 +3409,11 @@ module psb_d_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) @@ -3183,34 +3421,34 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner -#endif +#endif ! - !> + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_lpk_), intent(in) :: m,n class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_ld_coo_allocate_mnnz end interface - + !> \memberof psb_ld_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ld_coo_mold(a,b,info) - import + interface + subroutine psb_ld_coo_mold(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_ld_coo_sparse_mat @@ -3225,17 +3463,17 @@ module psb_d_base_mat_mod ! interface subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ld_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_ld_coo_sparse_mat @@ -3244,16 +3482,16 @@ module psb_d_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_ld_coo_get_nz_row(idx,a) result(res) - import + import class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res end function psb_ld_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -3265,12 +3503,12 @@ module psb_d_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_lpk_), intent(in) :: nr,nc,nzin integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -3280,164 +3518,164 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_ld_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_ld_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_ld_fix_coo(a,info,idir) - import + interface + subroutine psb_ld_fix_coo(a,info,idir) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_ld_fix_coo end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_ld_cp_coo_to_coo(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_ld_cp_coo_from_coo(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_coo_from_coo end interface - - - !> + + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_coo_to_icoo(a,b,info) - import + interface + subroutine psb_ld_cp_coo_to_icoo(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_coo_to_icoo end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_coo_from_icoo(a,b,info) - import + interface + subroutine psb_ld_cp_coo_from_icoo(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_coo_from_icoo end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - !! - interface - subroutine psb_ld_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_ld_cp_coo_to_fmt(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt - !! - interface - subroutine psb_ld_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_ld_cp_coo_from_fmt(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo - interface - subroutine psb_ld_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_ld_mv_coo_to_coo(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo - interface - subroutine psb_ld_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_ld_mv_coo_from_coo(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt - interface - subroutine psb_ld_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_ld_mv_coo_to_fmt(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt - interface - subroutine psb_ld_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_ld_mv_coo_from_fmt(a,b,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_ld_coo_cp_from(a,b) - import + import class(psb_ld_coo_sparse_mat), intent(inout) :: a type(psb_ld_coo_sparse_mat), intent(in) :: b end subroutine psb_ld_coo_cp_from end interface - - interface + + interface subroutine psb_ld_coo_mv_from(a,b) - import + import class(psb_ld_coo_sparse_mat), intent(inout) :: a type(psb_ld_coo_sparse_mat), intent(inout) :: b end subroutine psb_ld_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_ld_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -3454,9 +3692,9 @@ module psb_d_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& @@ -3464,14 +3702,14 @@ module psb_d_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_coo_csput_a end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3483,14 +3721,14 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_coo_csgetptn end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow - interface + interface subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3503,39 +3741,39 @@ module psb_d_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_coo_csgetrow end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag - interface - subroutine psb_ld_coo_get_diag(a,d,info) - import + interface + subroutine psb_ld_coo_get_diag(a,d,info) + import class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_coo_get_diag end interface - - - !> + + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scal - interface - subroutine psb_ld_coo_scal(d,a,info,side) - import + interface + subroutine psb_ld_coo_scal(d,a,info,side) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_ld_coo_scal end interface - - !> + + !> !! \memberof psb_ld_coo_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scals interface - subroutine psb_ld_coo_scals(d,a,info) - import + subroutine psb_ld_coo_scals(d,a,info) + import class(psb_ld_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3543,11 +3781,64 @@ module psb_d_base_mat_mod end interface public :: psb_d_get_print_frmt, psb_ld_get_print_frmt - + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scalplusidentity + interface + subroutine psb_ld_coo_scalplusidentity(d,a,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_scalplusidentity + end interface + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_spaxpby + interface + subroutine psb_ld_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_spaxpby + end interface + + ! + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cmpval + interface + function psb_ld_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ld_coo_cmpval + end interface + + ! + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cmpmat + interface + function psb_ld_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ld_coo_cmpmat + end interface + contains - + function psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_ipk_), intent(in) :: nr, nc, nz @@ -3562,17 +3853,17 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_d_get_print_frmt - + function psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_lpk_), intent(in) :: nr, nc, nz @@ -3587,109 +3878,109 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_ld_get_print_frmt - - + + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function d_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function d_coo_sizeof - - + + function d_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function d_coo_get_fmt - - + + function d_coo_get_size(a) result(res) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function d_coo_get_size - - + + function d_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%nnz end function d_coo_get_nzeros - + function d_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function d_coo_is_by_rows - + function d_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function d_coo_is_by_cols - + function d_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function d_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3697,52 +3988,52 @@ contains ! ! ! == ================================== - + subroutine d_coo_set_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine d_coo_set_nzeros - + function d_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_d_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function d_coo_get_sort_status - + subroutine d_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_d_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine d_coo_set_sort_status - - + + subroutine d_coo_set_by_rows(a) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine d_coo_set_by_rows - - + + subroutine d_coo_set_by_cols(a) - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine d_coo_set_by_cols - + ! == ================================== ! ! @@ -3754,12 +4045,12 @@ contains ! ! ! == ================================== - - subroutine d_coo_free(a) - implicit none - + + subroutine d_coo_free(a) + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -3768,13 +4059,13 @@ contains call a%set_ncols(0_psb_ipk_) call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine d_coo_free - - - + + + ! == ================================== ! ! @@ -3788,132 +4079,132 @@ contains ! ! == ================================== subroutine d_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a - - integer(psb_ipk_), allocatable :: itemp(:) + + integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_d_base_sparse_mat%psb_base_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine d_coo_transp_1mat - + subroutine d_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_d_is_complex_) a%val(:) = (a%val(:)) end subroutine d_coo_transc_1mat - + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function ld_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_lp res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function ld_coo_sizeof - - + + function ld_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function ld_coo_get_fmt - - + + function ld_coo_get_size(a) result(res) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function ld_coo_get_size - - + + function ld_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%nnz end function ld_coo_get_nzeros - + function ld_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function ld_coo_is_by_rows - + function ld_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function ld_coo_is_by_cols - + function ld_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function ld_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3921,63 +4212,63 @@ contains ! ! ! == ================================== - + subroutine ld_coo_iset_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_ld_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine ld_coo_iset_nzeros #if defined(IPK4) && defined(LPK8) subroutine ld_coo_lset_nzeros(nz,a) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ld_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine ld_coo_lset_nzeros #endif - + function ld_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_ld_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function ld_coo_get_sort_status - + subroutine ld_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_ld_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine ld_coo_set_sort_status - - + + subroutine ld_coo_set_by_rows(a) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine ld_coo_set_by_rows - - + + subroutine ld_coo_set_by_cols(a) - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine ld_coo_set_by_cols - + ! == ================================== ! ! @@ -3989,12 +4280,12 @@ contains ! ! ! == ================================== - - subroutine ld_coo_free(a) - implicit none - + + subroutine ld_coo_free(a) + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -4003,13 +4294,13 @@ contains call a%set_ncols(0_psb_lpk_) call a%set_nzeros(0_psb_lpk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine ld_coo_free - - - + + + ! == ================================== ! ! @@ -4023,40 +4314,37 @@ contains ! ! == ================================== subroutine ld_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a - - integer(psb_lpk_), allocatable :: itemp(:) + + integer(psb_lpk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_ld_base_sparse_mat%psb_lbase_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine ld_coo_transp_1mat - + subroutine ld_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_ld_is_complex_) a%val(:) = (a%val(:)) end subroutine ld_coo_transc_1mat end module psb_d_base_mat_mod - - - diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 8a59b5134..0311e9949 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_d_base_vect_mod ! ! This module contains the definition of the psb_d_base_vect type which ! is a container for dense vectors. -! This is encapsulated instead of being just a simple array to allow for +! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran ! side. It is also meant to be encapsulated in an outer type, to allow @@ -43,7 +43,7 @@ ! ! module psb_d_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_d_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_d_base_vect_type - !! The psb_d_base_vect_type + !! The psb_d_base_vect_type !! defines a middle level real(psb_dpk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow @@ -61,9 +61,9 @@ module psb_d_base_vect_mod !! sparse matrix types. !! type psb_d_base_vect_type - !> Values. + !> Values. real(psb_dpk_), allocatable :: v(:) - real(psb_dpk_), allocatable :: combuf(:) + real(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_d_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => d_base_ins_a procedure, pass(x) :: ins_v => d_base_ins_v @@ -93,7 +93,7 @@ module psb_d_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => d_base_sync procedure, pass(x) :: is_host => d_base_is_host @@ -130,7 +130,7 @@ module psb_d_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => d_base_gthab procedure, pass(x) :: gthzv => d_base_gthzv @@ -151,7 +151,9 @@ module psb_d_base_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => d_base_axpby_v procedure, pass(y) :: axpby_a => d_base_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => d_base_axpby_v2 + procedure, pass(z) :: axpby_a2 => d_base_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 ! ! Vector by vector multiplication. Need all variants ! to handle multiple requirements from preconditioners @@ -162,7 +164,24 @@ module psb_d_base_vect_mod procedure, pass(z) :: mlt_v_2 => d_base_mlt_v_2 procedure, pass(z) :: mlt_va => d_base_mlt_va procedure, pass(z) :: mlt_av => d_base_mlt_av - generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va + generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, & + mlt_va + ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => d_base_div_v + procedure, pass(x) :: div_v_check => d_base_div_v_check + procedure, pass(z) :: div_v2 => d_base_div_v2 + procedure, pass(z) :: div_v2_check => d_base_div_v2_check + procedure, pass(z) :: div_a2 => d_base_div_a2 + procedure, pass(z) :: div_a2_check => d_base_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => d_base_inv_v + procedure, pass(y) :: inv_v_check => d_base_inv_v_check + procedure, pass(y) :: inv_a2 => d_base_inv_a2 + procedure, pass(y) :: inv_a2_check => d_base_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check ! ! Scaling and norms ! @@ -174,6 +193,29 @@ module psb_d_base_vect_mod procedure, pass(x) :: amax => d_base_amax procedure, pass(x) :: asum => d_base_asum + ! + ! Comparison and mask operation + ! + procedure, pass(z) :: acmp_a2 => d_base_acmp_a2 + procedure, pass(z) :: acmp_v2 => d_base_acmp_v2 + generic, public :: acmp => acmp_a2,acmp_v2 + ! + ! Add constant value to all entry of a vector + ! + procedure, pass(z) :: addconst_a2 => d_base_addconst_a2 + procedure, pass(z) :: addconst_v2 => d_base_addconst_v2 + generic, public :: addconst => addconst_a2,addconst_v2 + + procedure, pass(x) :: minreal => d_base_min + procedure, pass(m) :: mask_v => d_base_mask_v + procedure, pass(m) :: mask_a => d_base_mask_a + generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => d_base_minquotient_v + procedure, pass(x) :: minquotient_a2 => d_base_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 + + + end type psb_d_base_vect_type public :: psb_d_base_vect @@ -183,11 +225,11 @@ module psb_d_base_vect_mod end interface psb_d_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +242,11 @@ contains this%v = x call this%asb(size(x,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +256,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +268,20 @@ contains !! subroutine d_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: this(:) class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine d_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +289,11 @@ contains !> Function bld_mn: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine d_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +302,15 @@ contains call x%asb(n,info) end subroutine d_base_bld_mn - + !> Function bld_en: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine d_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +319,24 @@ contains call x%asb(n,info) end subroutine d_base_bld_en - + !> Function base_all: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine d_base_all(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_base_vect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(n,x%v,info) - + end subroutine d_base_all !> Function base_mold: @@ -306,11 +348,11 @@ contains subroutine d_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x class(psb_d_base_vect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_d_base_vect_type :: y, stat=info) end subroutine d_base_mold @@ -320,21 +362,21 @@ contains ! !> Function base_ins: !! \memberof psb_d_base_vect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -344,7 +386,7 @@ contains ! subroutine d_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +396,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -376,7 +418,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +436,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +445,7 @@ contains subroutine d_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +455,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() call x%ins(n,irl%v,val%v,dupl,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +478,14 @@ contains ! subroutine d_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=dzero call x%set_host() end subroutine d_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +494,20 @@ contains !> Function base_asb: !! \memberof psb_d_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine d_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +524,20 @@ contains !> Function base_asb: !! \memberof psb_d_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine d_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +550,39 @@ contains !> Function base_free: !! \memberof psb_d_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine d_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if (info == 0) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine d_base_free - + ! !> Function base_free_buffer: !! \memberof psb_d_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine d_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +597,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine d_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +617,13 @@ contains !> Function base_free_comid: !! \memberof psb_d_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine d_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +635,77 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_d_base_vect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine d_base_sync(x) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x - + end subroutine d_base_sync ! !> Function base_set_host: !! \memberof psb_d_base_vect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine d_base_set_host(x) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x - + end subroutine d_base_set_host ! !> Function base_set_dev: !! \memberof psb_d_base_vect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine d_base_set_dev(x) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x - + end subroutine d_base_set_dev ! !> Function base_set_sync: !! \memberof psb_d_base_vect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine d_base_set_sync(x) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x - + end subroutine d_base_set_sync ! !> Function base_is_dev: !! \memberof psb_d_base_vect_type !! \brief Is vector on external device . - !! + !! ! function d_base_is_dev(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x logical :: res - + res = .false. end function d_base_is_dev - + ! !> Function base_is_host !! \memberof psb_d_base_vect_type !! \brief Is vector on standard memory . - !! + !! ! function d_base_is_host(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +716,10 @@ contains !> Function base_is_sync !! \memberof psb_d_base_vect_type !! \brief Is vector on sync . - !! + !! ! function d_base_is_sync(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +728,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_d_base_vect_type !! \brief Number of entries - !! + !! ! function d_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +750,13 @@ contains !> Function base_get_sizeof !! \memberof psb_d_base_vect_type !! \brief Size in bytes - !! + !! ! function d_base_sizeof(x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(in) :: x integer(psb_epk_) :: res - + ! Force 8-byte integers. res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() @@ -724,14 +766,14 @@ contains !> Function base_get_fmt !! \memberof psb_d_base_vect_type !! \brief Format - !! + !! ! function d_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function d_base_get_fmt - + ! ! @@ -740,7 +782,7 @@ contains !! \memberof psb_d_base_vect_type !! \brief Extract a copy of the contents !! - ! + ! function d_base_get_vect(x,n) result(res) class(psb_d_base_vect_type), intent(inout) :: x real(psb_dpk_), allocatable :: res(:) @@ -748,21 +790,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + if (.not.allocated(x%v)) return if (.not.x%is_host()) call x%sync() isz = x%get_nrows() if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function d_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +813,18 @@ contains !! \param val The value to set !! subroutine d_base_set_scal(x,val,first,last) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_ first_=1 last_=size(x%v) if (present(first)) first_ = max(1,first) if (present(last)) last_ = min(last,last_) - + if (x%is_dev()) call x%sync() x%v(first_:last_) = val call x%set_host() @@ -794,14 +836,14 @@ contains !> Function base_set_vect !! \memberof psb_d_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine d_base_set_vect(x,val,first,last) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +851,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +871,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine d_base_absval1(x) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +883,21 @@ contains end subroutine d_base_absval1 subroutine d_base_absval2(x,y) - implicit none - class(psb_d_base_vect_type), intent(inout) :: x + implicit none + class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: y integer(psb_ipk_) :: info if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) call y%absval() end if - + end subroutine d_base_absval2 ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_d_base_vect_type @@ -864,12 +906,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function d_base_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res real(psb_dpk_), external :: ddot - + res = dzero ! ! Note: this is the base implementation. @@ -898,19 +940,19 @@ contains !! \param y(:) The array to be multiplied by !! function d_base_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res real(psb_dpk_), external :: ddot - + res = ddot(n,y,1,x%v,1) end function d_base_dot_a - + ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +967,13 @@ contains !! subroutine d_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: y real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (x%is_dev()) call x%sync() call y%axpby(m,alpha,x%v,beta,info) @@ -939,7 +981,39 @@ contains end subroutine d_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_d_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar alpha + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + subroutine d_base_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine d_base_axpby_v2 + + ! + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +1027,50 @@ contains !! subroutine d_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent(in) :: x(:) class(psb_d_base_vect_type), intent(inout) :: y real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (y%is_dev()) call y%sync() call psb_geaxpby(m,alpha,x,beta,y%v,info) call y%set_host() - + end subroutine d_base_axpby_a - + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_d_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + subroutine d_base_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine d_base_axpby_a2 + + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +1088,10 @@ contains !! subroutine d_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1109,7 @@ contains !! subroutine d_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:) class(psb_d_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1118,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1139,7 @@ contains !! subroutine d_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) real(psb_dpk_), intent(in) :: x(:) @@ -1043,58 +1147,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (z%is_dev()) call z%sync() n = min(size(z%v), size(x), size(y)) - if (alpha == dzero) then - if (beta == done) then - return + if (alpha == dzero) then + if (beta == done) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == done) then - if (beta == dzero) then - do i=1, n + if (alpha == done) then + if (beta == dzero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == done) then - do i=1, n + else if (beta == done) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + y(i)*x(i) end do end if - else if (alpha == -done) then - if (beta == dzero) then - do i=1, n + else if (alpha == -done) then + if (beta == dzero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == done) then - do i=1, n + else if (beta == done) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == dzero) then - do i=1, n + if (beta == dzero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == done) then - do i=1, n + else if (beta == done) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1222,12 @@ contains subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: y class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1237,7 @@ contains if (x%is_dev()) call x%sync() if (.not.psb_d_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1252,12 @@ contains subroutine d_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: x(:) class(psb_d_base_vect_type), intent(inout) :: y class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1268,12 @@ contains subroutine d_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1281,318 @@ contains call z%mlt(alpha,y,x,beta,info) end subroutine d_base_mlt_va + ! + !> Function base_div_v + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine d_base_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info) + + + end subroutine d_base_div_v + ! + !> Function base_div_v2 + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine d_base_div_v2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + end subroutine d_base_div_v2 + ! + !> Function base_div_v_check + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine d_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine d_base_div_v_check + ! + !> Function base_div_v2_check + !! \memberof psb_d_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine d_base_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + + end subroutine d_base_div_v2_check + ! + !> Function base_div_a2 + !! \memberof psb_d_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + subroutine d_base_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine d_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine d_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: z + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call d_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + + end subroutine d_base_div_a2_check + ! + !> Function base_inv_v + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + subroutine d_base_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine d_base_inv_v + ! + !> Function base_inv_v_check + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + subroutine d_base_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + + end subroutine d_base_inv_v_check + ! + !> Function base_inv_a2 + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + subroutine d_base_inv_a2(x, y, info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + y%v(i) = 1_psb_dpk_/x(i) + end do + + end subroutine d_base_inv_a2 + ! + !> Function base_inv_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + subroutine d_base_inv_a2_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call d_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_dpk_/x(i) + else + info = 1 + y%v(i) = 0_psb_dpk_ + end if + end do + end if + + + end subroutine d_base_inv_a2_check ! - ! Simple scaling + !> Function base_inv_a2_check + !! \memberof psb_d_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine d_base_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_dpk_ + else + z%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + + end subroutine d_base_acmp_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_d_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine d_base_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine d_base_acmp_v2 + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_d_base_vect_type @@ -1189,17 +1601,17 @@ contains !! subroutine d_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine d_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,50 +1620,122 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function d_base_nrm2(n,x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res real(psb_dpk_), external :: dnrm2 - + if (x%is_dev()) call x%sync() res = dnrm2(n,x%v,1) end function d_base_nrm2 - + ! !> Function base_amax !! \memberof psb_d_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function d_base_amax(n,x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) end function d_base_amax + ! + !> Function base_min + !! \memberof psb_d_base_vect_type + !! \brief min x(1:n) + !! \param n how many entries to consider + function d_base_min(n,x) result(res) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (x%is_dev()) call x%sync() + res = minval(x%v(1:n)) + + end function d_base_min + + ! + !> Function base_minquotient_v + !! \memberof psb_d_base_vect_type + !! \brief Minimum entry of the vector entry-by-entry divide x/y + !! \param x The numerator vector + !! \param y The denumerator vector + !! \param info return code + !! + function d_base_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + + z = x%minquotient(y%v,info) + + end function d_base_minquotient_v + + ! + !> Function base_minquotient_a2 + !! \memberof psb_d_base_vect_type + !! \brief Minimum entry of the array entry-by-entry divide x/y + !! \param x The numerator array + !! \param y The denumerator array + !! \param info return code + !! + function d_base_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + real(psb_dpk_) :: temp + + info = 0 + + z = huge(z) + n = min(size(y), size(x%v)) + do i=1, n + if ( y(i) /= dzero ) then + temp = x%v(i)/y(i) + if (temp <= z) z = temp + end if + end do + + end function d_base_minquotient_a2 + + ! !> Function base_asum !! \memberof psb_d_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function d_base_asum(n,x) result(res) - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function d_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1750,18 @@ contains !! \param beta subroutine d_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: alpha, beta, y(:) class(psb_d_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,alpha,x%v,beta,y) end subroutine d_base_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_d_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1286,28 +1770,28 @@ contains !! \param idx(:) indices subroutine d_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: y(:) class(psb_d_base_vect_type) :: x - + if (idx%is_dev()) call idx%sync() call x%gth(n,idx%v(i:),y) end subroutine d_base_gthzv_x ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine d_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_d_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1804,22 @@ contains !> Function base_device_wait: !! \memberof psb_d_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine d_base_device_wait() - implicit none - + implicit none + end subroutine d_base_device_wait function d_base_use_buffer() result(res) logical :: res - + res = .true. end function d_base_use_buffer subroutine d_base_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1829,7 @@ contains subroutine d_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1840,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_d_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1849,20 @@ contains !! \param idx(:) indices subroutine d_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: y(:) class(psb_d_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,x%v,y) end subroutine d_base_gthzv ! - ! Scatter: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_d_base_vect_type @@ -1387,14 +1871,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine d_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:) class(psb_d_base_vect_type) :: y - + if (y%is_dev()) call y%sync() call psi_sct(n,idx,x,beta,y%v) call y%set_host() @@ -1403,12 +1887,12 @@ contains subroutine d_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: beta, x(:) class(psb_d_base_vect_type) :: y - + if (idx%is_dev()) call idx%sync() call y%sct(n,idx%v(i:),x,beta) call y%set_host() @@ -1417,14 +1901,14 @@ contains subroutine d_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: beta class(psb_d_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1435,6 +1919,147 @@ contains end subroutine d_base_sctb_buf + ! + !> Function base_mask_a + !! \memberof psb_d_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The array to be compared + !! \param c The array containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + subroutine d_base_mask_a(c,x,m,t,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(inout) :: c(:) + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + integer(psb_ipk_) :: i, n + + if (m%is_dev()) call m%sync() + t = .true. + + n = size(x) + do i = 1, n, 1 + if (c(i).eq.2_psb_dpk_) then + if ( x(i) > dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + elseif (c(i).eq.1_psb_dpk_) then + if ( x(i) >= dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + elseif (c(i).eq.-1_psb_dpk_) then + if ( x(i) <= dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + elseif (c(i).eq.-2_psb_dpk_) then + if ( x(i) < dzero ) then + m%v(i) = 0_psb_dpk_ + else + m%v(i) = 1_psb_dpk_ + t = .false. + end if + else + m%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + + end subroutine d_base_mask_a + ! + !> Function base_mask_v + !! \memberof psb_d_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The vector to be compared + !! \param c The vector containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + subroutine d_base_mask_v(c,x,m,t,info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: c + class(psb_d_base_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + + info = 0 + if (x%is_dev()) call x%sync() + if (c%is_dev()) call c%sync() + + call m%mask(x%v,c%v,t,info) + end subroutine d_base_mask_v + + + ! + !> Function _base_addconst_a2 + !! \memberof psb_d_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine d_base_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: b + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + z%v(i) = x(i) + b + end do + info = 0 + + end subroutine d_base_addconst_a2 + ! + !> Function _base_addconst_v2 + !! \memberof psb_d_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine d_base_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: b + class(psb_d_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine d_base_addconst_v2 end module psb_d_base_vect_mod @@ -1449,22 +2074,22 @@ module psb_d_base_multivect_mod use psb_d_base_vect_mod !> \namespace psb_base_mod \class psb_d_base_vect_type - !! The psb_d_base_vect_type + !! The psb_d_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private + private public :: psb_d_base_multivect, psb_d_base_multivect_type type psb_d_base_multivect_type - !> Values. + !> Values. real(psb_dpk_), allocatable :: v(:,:) - real(psb_dpk_), allocatable :: combuf(:) + real(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +2103,7 @@ module psb_d_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => d_base_mlv_ins procedure, pass(x) :: zero => d_base_mlv_zero @@ -1489,7 +2114,7 @@ module psb_d_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => d_base_mlv_sync procedure, pass(x) :: is_host => d_base_mlv_is_host @@ -1562,7 +2187,7 @@ module psb_d_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => d_base_mlv_gthab procedure, pass(x) :: gthzv => d_base_mlv_gthzv @@ -1584,7 +2209,7 @@ module psb_d_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +2228,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +2255,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +2270,7 @@ contains !> Function bld_n: !! \memberof psb_d_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine d_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +2287,13 @@ contains !! \memberof psb_d_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine d_base_mlv_all(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +2311,7 @@ contains subroutine d_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x class(psb_d_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info @@ -1700,21 +2325,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_d_base_multivect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -1724,7 +2349,7 @@ contains ! subroutine d_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +2359,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -1756,7 +2381,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +2398,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +2413,7 @@ contains ! subroutine d_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=dzero @@ -1804,7 +2429,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_d_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +2438,7 @@ contains subroutine d_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +2455,20 @@ contains !> Function base_mlv_free: !! \memberof psb_d_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine d_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine d_base_mlv_free @@ -1853,15 +2478,15 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_mlv_sync: !! \memberof psb_d_base_multivect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine d_base_mlv_sync(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_sync @@ -1870,10 +2495,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_d_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine d_base_mlv_set_host(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_set_host @@ -1882,10 +2507,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_d_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine d_base_mlv_set_dev(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_set_dev @@ -1894,10 +2519,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_d_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine d_base_mlv_set_sync(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x end subroutine d_base_mlv_set_sync @@ -1906,10 +2531,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_d_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function d_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +2545,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_d_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function d_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +2559,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_d_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function d_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +2571,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_d_base_multivect_type !! \brief Number of entries - !! + !! ! function d_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2590,7 @@ contains end function d_base_mlv_get_nrows function d_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2603,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_d_base_multivect_type !! \brief Size in bytesa - !! + !! ! function d_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2619,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_d_base_multivect_type !! \brief Format - !! + !! ! function d_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function d_base_mlv_get_fmt @@ -2010,18 +2635,18 @@ contains !! \memberof psb_d_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function d_base_mlv_get_vect(x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), allocatable :: res(:,:) integer(psb_ipk_) :: info,m,n m = x%get_nrows() n = x%get_ncols() - if (.not.allocated(x%v)) return + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2654,7 @@ contains end function d_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2663,7 @@ contains !! \param val The value to set !! subroutine d_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val @@ -2051,16 +2676,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_d_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine d_base_mlv_set_vect(x,val) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_) :: nr, nc integer(psb_ipk_) :: info - if (allocated(x%v)) then + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2697,8 @@ contains end subroutine d_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_d_base_multivect_type @@ -2082,7 +2707,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function d_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2094,7 +2719,7 @@ contains ! ! Note: this is the base implementation. ! When we get here, we are sure that X is of - ! TYPE psb_d_base_mlv_vect (or its class does not care). + ! TYPE psb_d_base_mlv_vect (or its class does not care). ! If Y is not, throw the burden on it, implicitly ! calling dot_a ! @@ -2123,7 +2748,7 @@ contains !! \param y(:) The array to be multiplied by !! function d_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2766,7 @@ contains end function d_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2781,7 @@ contains !! subroutine d_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_d_base_multivect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: y @@ -2180,7 +2805,7 @@ contains end subroutine d_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2819,7 @@ contains !! subroutine d_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent(in) :: x(:,:) class(psb_d_base_multivect_type), intent(inout) :: y @@ -2230,10 +2855,10 @@ contains !! subroutine d_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2868,10 @@ contains subroutine d_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_d_base_vect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2888,7 @@ contains !! subroutine d_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:) class(psb_d_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2896,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2911,7 @@ contains !! subroutine d_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:,:) class(psb_d_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2938,7 @@ contains !! subroutine d_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:,:) real(psb_dpk_), intent(in) :: x(:,:) @@ -2321,38 +2946,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + info = 0 nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == dzero) then - if (beta == done) then - return + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == dzero) then + if (beta == done) then + return else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) end if else - if (alpha == done) then - if (beta == dzero) then + if (alpha == done) then + if (beta == dzero) then z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == done) then + else if (beta == done) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) end if - else if (alpha == -done) then - if (beta == dzero) then + else if (alpha == -done) then + if (beta == dzero) then z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == done) then + else if (beta == done) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) end if else - if (beta == dzero) then + if (beta == dzero) then z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == done) then + else if (beta == done) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) end if end if @@ -2373,12 +2998,12 @@ contains subroutine d_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta class(psb_d_base_multivect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: y class(psb_d_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +3014,7 @@ contains if (z%is_dev()) call z%sync() if (.not.psb_d_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +3029,39 @@ contains !!$ !!$ subroutine d_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_base_multivect_type), intent(inout) :: y !!$ class(psb_d_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,x,y%v,beta,info) !!$ !!$ end subroutine d_base_mlv_mlt_av !!$ !!$ subroutine d_base_mlv_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: y(:) !!$ class(psb_d_base_multivect_type), intent(inout) :: x !!$ class(psb_d_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,y,x,beta,info) !!$ !!$ end subroutine d_base_mlv_mlt_va !!$ !!$ ! - ! Simple scaling + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_d_base_multivect_type @@ -2445,7 +3070,7 @@ contains !! subroutine d_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha @@ -2462,7 +3087,7 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function d_base_mlv_nrm2(n,x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2484,7 +3109,7 @@ contains !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function d_base_mlv_amax(n,x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2505,7 +3130,7 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function d_base_mlv_asum(n,x) result(res) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2528,7 +3153,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine d_base_mlv_absval1(x) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +3165,13 @@ contains end subroutine d_base_mlv_absval1 subroutine d_base_mlv_absval2(x,y) - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x class(psb_d_base_multivect_type), intent(inout) :: y integer(psb_ipk_) :: info - + if (x%is_dev()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),done,x,dzero,info) call y%absval() end if @@ -2555,15 +3180,15 @@ contains function d_base_mlv_use_buffer() result(res) - implicit none + implicit none logical :: res - + res = .true. end function d_base_mlv_use_buffer subroutine d_base_mlv_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +3200,7 @@ contains subroutine d_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +3211,12 @@ contains subroutine d_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +3224,7 @@ contains subroutine d_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +3234,7 @@ contains subroutine d_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_d_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +3257,7 @@ contains !! \param beta subroutine d_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: alpha, beta, y(:) class(psb_d_base_multivect_type) :: x @@ -2648,7 +3273,7 @@ contains end subroutine d_base_mlv_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_d_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2657,7 +3282,7 @@ contains !! \param idx(:) indices subroutine d_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: y(:) @@ -2670,7 +3295,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_d_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2679,7 +3304,7 @@ contains !! \param idx(:) indices subroutine d_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: y(:) class(psb_d_base_multivect_type) :: x @@ -2696,7 +3321,7 @@ contains end subroutine d_base_mlv_gthzv ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_d_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2705,7 +3330,7 @@ contains !! \param idx(:) indices subroutine d_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: y(:,:) class(psb_d_base_multivect_type) :: x @@ -2722,17 +3347,17 @@ contains end subroutine d_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine d_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_d_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +3369,9 @@ contains end subroutine d_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_d_base_multivect_type @@ -2755,10 +3380,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine d_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:) class(psb_d_base_multivect_type) :: y @@ -2773,7 +3398,7 @@ contains subroutine d_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_dpk_) :: beta, x(:,:) class(psb_d_base_multivect_type) :: y @@ -2788,7 +3413,7 @@ contains subroutine d_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real( psb_dpk_) :: beta, x(:) @@ -2800,14 +3425,14 @@ contains subroutine d_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n class(psb_i_base_vect_type) :: idx real(psb_dpk_) :: beta class(psb_d_base_multivect_type) :: y integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +3441,18 @@ contains nc = y%get_ncols() call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) call y%set_host() - + end subroutine d_base_mlv_sctb_buf ! !> Function base_device_wait: !! \memberof psb_d_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine d_base_mlv_device_wait() - implicit none - + implicit none + end subroutine d_base_mlv_device_wait end module psb_d_base_multivect_mod - diff --git a/base/modules/serial/psb_d_csc_mat_mod.f90 b/base/modules/serial/psb_d_csc_mat_mod.f90 index 8a479926d..60d91bf29 100644 --- a/base/modules/serial/psb_d_csc_mat_mod.f90 +++ b/base/modules/serial/psb_d_csc_mat_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_d_csc_mat_mod ! @@ -40,23 +40,23 @@ ! ! Please refere to psb_d_base_mat_mod for a detailed description ! of the various methods, and to psb_d_csc_impl for implementation details. -! +! module psb_d_csc_mat_mod use psb_d_base_mat_mod !> \namespace psb_base_mod \class psb_d_csc_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat - !! + !! !! psb_d_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_d_base_sparse_mat) :: psb_d_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_ipk_), allocatable :: icp(:) !> Row indices. integer(psb_ipk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. real(psb_dpk_), allocatable :: val(:) contains @@ -107,16 +107,16 @@ module psb_d_csc_mat_mod !> \namespace psb_base_mod \class psb_d_csc_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat - !! + !! !! psb_d_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_ld_base_sparse_mat) :: psb_ld_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_lpk_), allocatable :: icp(:) !> Row indices. integer(psb_lpk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. real(psb_dpk_), allocatable :: val(:) contains @@ -163,23 +163,23 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_d_csc_reallocate_nz(nz,a) + subroutine psb_d_csc_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_d_csc_sparse_mat), intent(inout) :: a end subroutine psb_d_csc_reallocate_nz end interface - + !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_d_csc_reinit(a,clear) import - class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_csc_reinit end interface - + !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -188,22 +188,22 @@ module psb_d_csc_mat_mod class(psb_d_csc_sparse_mat), intent(inout) :: a end subroutine psb_d_csc_trim end interface - + !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_d_csc_mold(a,b,info) + interface + subroutine psb_d_csc_mold(a,b,info) import class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csc_mold end interface - + !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -211,147 +211,147 @@ module psb_d_csc_mat_mod end subroutine psb_d_csc_allocate_mnnz end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_print interface subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_d_csc_print end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo - interface - subroutine psb_d_cp_csc_to_coo(a,b,info) + interface + subroutine psb_d_cp_csc_to_coo(a,b,info) import class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csc_to_coo end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo - interface - subroutine psb_d_cp_csc_from_coo(a,b,info) + interface + subroutine psb_d_cp_csc_from_coo(a,b,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csc_from_coo end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_to_fmt - interface - subroutine psb_d_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_d_cp_csc_to_fmt(a,b,info) import class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csc_to_fmt end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_fmt - interface - subroutine psb_d_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_d_cp_csc_from_fmt(a,b,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csc_from_fmt end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_to_coo - interface - subroutine psb_d_mv_csc_to_coo(a,b,info) + interface + subroutine psb_d_mv_csc_to_coo(a,b,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csc_to_coo end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo - interface - subroutine psb_d_mv_csc_from_coo(a,b,info) + interface + subroutine psb_d_mv_csc_from_coo(a,b,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csc_from_coo end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_to_fmt - interface - subroutine psb_d_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_d_mv_csc_to_fmt(a,b,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csc_to_fmt end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt - interface - subroutine psb_d_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_d_mv_csc_from_fmt(a,b,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_clean_zeros ! interface subroutine psb_d_csc_clean_zeros(a, info) - import + import class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csc_clean_zeros end interface - - + + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from - interface + interface subroutine psb_d_csc_cp_from(a,b) import class(psb_d_csc_sparse_mat), intent(inout) :: a type(psb_d_csc_sparse_mat), intent(in) :: b end subroutine psb_d_csc_cp_from end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from - interface + interface subroutine psb_d_csc_mv_from(a,b) import class(psb_d_csc_sparse_mat), intent(inout) :: a type(psb_d_csc_sparse_mat), intent(inout) :: b end subroutine psb_d_csc_mv_from end interface - - + + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csput_a - interface - subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -360,10 +360,10 @@ module psb_d_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csc_csput_a end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -378,10 +378,10 @@ module psb_d_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_csc_csgetptn end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csgetrow - interface + interface subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ @@ -400,7 +400,7 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csgetblk - interface + interface subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) import @@ -414,11 +414,11 @@ module psb_d_csc_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_csc_csgetblk end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssv - interface - subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -429,8 +429,8 @@ module psb_d_csc_mat_mod end interface !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssm - interface - subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -439,11 +439,11 @@ module psb_d_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_csc_cssm end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csmv - interface - subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -455,8 +455,8 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csmm - interface - subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -465,21 +465,21 @@ module psb_d_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_csc_csmm end interface - - + + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_maxval - interface + interface function psb_d_csc_maxval(a) result(res) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csc_maxval end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csnm1 - interface + interface function psb_d_csc_csnm1(a) result(res) import class(psb_d_csc_sparse_mat), intent(in) :: a @@ -489,8 +489,8 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_rowsum - interface - subroutine psb_d_csc_rowsum(d,a) + interface + subroutine psb_d_csc_rowsum(d,a) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -499,18 +499,18 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_arwsum - interface - subroutine psb_d_csc_arwsum(d,a) + interface + subroutine psb_d_csc_arwsum(d,a) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csc_arwsum end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_colsum - interface - subroutine psb_d_csc_colsum(d,a) + interface + subroutine psb_d_csc_colsum(d,a) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -519,29 +519,29 @@ module psb_d_csc_mat_mod !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_aclsum - interface - subroutine psb_d_csc_aclsum(d,a) + interface + subroutine psb_d_csc_aclsum(d,a) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csc_aclsum end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_get_diag - interface - subroutine psb_d_csc_get_diag(a,d,info) + interface + subroutine psb_d_csc_get_diag(a,d,info) import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csc_get_diag end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scal - interface - subroutine psb_d_csc_scal(d,a,info,side) + interface + subroutine psb_d_csc_scal(d,a,info,side) import class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) @@ -549,42 +549,41 @@ module psb_d_csc_mat_mod character, intent(in), optional :: side end subroutine psb_d_csc_scal end interface - + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scals interface - subroutine psb_d_csc_scals(d,a,info) + subroutine psb_d_csc_scals(d,a,info) import class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csc_scals end interface - ! ! ld - ! + ! !> \memberof psb_ld_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_ld_csc_reallocate_nz(nz,a) + subroutine psb_ld_csc_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_ld_csc_sparse_mat), intent(inout) :: a end subroutine psb_ld_csc_reallocate_nz end interface - + !> \memberof psb_ld_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_ld_csc_reinit(a,clear) import - class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ld_csc_reinit end interface - + !> \memberof psb_ld_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -593,22 +592,22 @@ module psb_d_csc_mat_mod class(psb_ld_csc_sparse_mat), intent(inout) :: a end subroutine psb_ld_csc_trim end interface - + !> \memberof psb_ld_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ld_csc_mold(a,b,info) + interface + subroutine psb_ld_csc_mold(a,b,info) import class(psb_ld_csc_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csc_mold end interface - + !> \memberof psb_ld_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_ld_csc_sparse_mat), intent(inout) :: a @@ -616,146 +615,146 @@ module psb_d_csc_mat_mod end subroutine psb_ld_csc_allocate_mnnz end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_print interface subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ld_csc_print end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_csc_to_coo(a,b,info) + interface + subroutine psb_ld_cp_csc_to_coo(a,b,info) import class(psb_ld_csc_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csc_to_coo end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_csc_from_coo(a,b,info) + interface + subroutine psb_ld_cp_csc_from_coo(a,b,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csc_from_coo end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt - interface - subroutine psb_ld_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_ld_cp_csc_to_fmt(a,b,info) import class(psb_ld_csc_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csc_to_fmt end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt - interface - subroutine psb_ld_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_ld_cp_csc_from_fmt(a,b,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csc_from_fmt end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo - interface - subroutine psb_ld_mv_csc_to_coo(a,b,info) + interface + subroutine psb_ld_mv_csc_to_coo(a,b,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csc_to_coo end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo - interface - subroutine psb_ld_mv_csc_from_coo(a,b,info) + interface + subroutine psb_ld_mv_csc_from_coo(a,b,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csc_from_coo end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt - interface - subroutine psb_ld_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_ld_mv_csc_to_fmt(a,b,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csc_to_fmt end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt - interface - subroutine psb_ld_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_ld_mv_csc_from_fmt(a,b,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros ! interface subroutine psb_ld_csc_clean_zeros(a, info) - import + import class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csc_clean_zeros end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from - interface + interface subroutine psb_ld_csc_cp_from(a,b) import class(psb_ld_csc_sparse_mat), intent(inout) :: a type(psb_ld_csc_sparse_mat), intent(in) :: b end subroutine psb_ld_csc_cp_from end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from - interface + interface subroutine psb_ld_csc_mv_from(a,b) import class(psb_ld_csc_sparse_mat), intent(inout) :: a type(psb_ld_csc_sparse_mat), intent(inout) :: b end subroutine psb_ld_csc_mv_from end interface - - + + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a - interface - subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -764,10 +763,10 @@ module psb_d_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csc_csput_a end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -782,10 +781,10 @@ module psb_d_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csc_csgetptn end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow - interface + interface subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -804,7 +803,7 @@ module psb_d_csc_mat_mod !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_csgetblk - interface + interface subroutine psb_ld_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import @@ -818,31 +817,31 @@ module psb_d_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csc_csgetblk end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag - interface - subroutine psb_ld_csc_get_diag(a,d,info) + interface + subroutine psb_ld_csc_get_diag(a,d,info) import class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csc_get_diag end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_maxval - interface + interface function psb_ld_csc_maxval(a) result(res) import class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_csc_maxval end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_csnm1 - interface + interface function psb_ld_csc_csnm1(a) result(res) import class(psb_ld_csc_sparse_mat), intent(in) :: a @@ -852,8 +851,8 @@ module psb_d_csc_mat_mod !> \memberof psb_ld_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_csc_rowsum(d,a) + interface + subroutine psb_ld_csc_rowsum(d,a) import class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -862,18 +861,18 @@ module psb_d_csc_mat_mod !> \memberof psb_ld_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_csc_arwsum(d,a) + interface + subroutine psb_ld_csc_arwsum(d,a) import class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_csc_arwsum end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_csc_colsum(d,a) + interface + subroutine psb_ld_csc_colsum(d,a) import class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -882,18 +881,18 @@ module psb_d_csc_mat_mod !> \memberof psb_ld_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_csc_aclsum(d,a) + interface + subroutine psb_ld_csc_aclsum(d,a) import class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_csc_aclsum end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scal - interface - subroutine psb_ld_csc_scal(d,a,info,side) + interface + subroutine psb_ld_csc_scal(d,a,info,side) import class(psb_ld_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) @@ -901,27 +900,25 @@ module psb_d_csc_mat_mod character, intent(in), optional :: side end subroutine psb_ld_csc_scal end interface - + !> \memberof psb_ld_csc_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scals interface - subroutine psb_ld_csc_scals(d,a,info) + subroutine psb_ld_csc_scals(d,a,info) import class(psb_ld_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csc_scals end interface - - -contains +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -929,54 +926,54 @@ contains ! ! == =================================== - + function d_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function d_csc_is_by_cols - + function d_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%icp) res = res + psb_sizeof_ip * psb_size(a%ia) - + end function d_csc_sizeof function d_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function d_csc_get_fmt - + function d_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%icp(a%get_ncols()+1)-1 end function d_csc_get_nzeros function d_csc_get_size(a) result(res) - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -988,17 +985,17 @@ contains function d_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function d_csc_get_nz_col @@ -1013,11 +1010,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine d_csc_free(a) - implicit none + subroutine d_csc_free(a) + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a @@ -1027,7 +1024,7 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine d_csc_free @@ -1038,7 +1035,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1046,57 +1043,57 @@ contains ! ! == =================================== - + function ld_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function ld_csc_is_by_cols ! ! ld ! - + function ld_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2*psb_sizeof_lp res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%icp) res = res + psb_sizeof_lp * psb_size(a%ia) - + end function ld_csc_sizeof function ld_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function ld_csc_get_fmt - + function ld_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%icp(a%get_ncols()+1)-1 end function ld_csc_get_nzeros function ld_csc_get_size(a) result(res) - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1108,17 +1105,17 @@ contains function ld_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_ld_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function ld_csc_get_nz_col @@ -1133,11 +1130,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine ld_csc_free(a) - implicit none + subroutine ld_csc_free(a) + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a @@ -1147,7 +1144,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine ld_csc_free diff --git a/base/modules/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index bd4cb9f9c..d0aa622bb 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -1,10 +1,10 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -16,7 +16,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -28,8 +28,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_d_csr_mat_mod ! @@ -48,17 +48,17 @@ module psb_d_csr_mat_mod !> \namespace psb_base_mod \class psb_d_csr_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat - !! + !! !! psb_d_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_d_base_sparse_mat) :: psb_d_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_ipk_), allocatable :: irp(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_dpk_), allocatable :: val(:) contains @@ -112,23 +112,23 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_d_csr_reallocate_nz(nz,a) + subroutine psb_d_csr_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_d_csr_sparse_mat), intent(inout) :: a end subroutine psb_d_csr_reallocate_nz end interface - + !> \memberof psb_d_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_d_csr_reinit(a,clear) import - class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_csr_reinit end interface - + !> \memberof psb_d_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -138,22 +138,22 @@ module psb_d_csr_mat_mod end subroutine psb_d_csr_trim end interface - + !> \memberof psb_d_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_d_csr_mold(a,b,info) + interface + subroutine psb_d_csr_mold(a,b,info) import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_mold end interface - + !> \memberof psb_d_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -161,14 +161,14 @@ module psb_d_csr_mat_mod end subroutine psb_d_csr_allocate_mnnz end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_print interface subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -187,27 +187,27 @@ module psb_d_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_d_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -216,13 +216,13 @@ module psb_d_csr_mat_mod class(psb_d_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_d_csr_tril end interface - + ! !> Function triu: !! \memberof psb_d_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -231,27 +231,27 @@ module psb_d_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_d_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -260,133 +260,133 @@ module psb_d_csr_mat_mod class(psb_d_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_d_csr_triu end interface - + ! - !> + !> !! \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_clean_zeros ! interface subroutine psb_d_csr_clean_zeros(a, info) - import + import class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_clean_zeros end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo - interface - subroutine psb_d_cp_csr_to_coo(a,b,info) + interface + subroutine psb_d_cp_csr_to_coo(a,b,info) import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csr_to_coo end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo - interface - subroutine psb_d_cp_csr_from_coo(a,b,info) + interface + subroutine psb_d_cp_csr_from_coo(a,b,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csr_from_coo end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_to_fmt - interface - subroutine psb_d_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_d_cp_csr_to_fmt(a,b,info) import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csr_to_fmt end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from_fmt - interface - subroutine psb_d_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_d_cp_csr_from_fmt(a,b,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csr_from_fmt end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_to_coo - interface - subroutine psb_d_mv_csr_to_coo(a,b,info) + interface + subroutine psb_d_mv_csr_to_coo(a,b,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csr_to_coo end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo - interface - subroutine psb_d_mv_csr_from_coo(a,b,info) + interface + subroutine psb_d_mv_csr_from_coo(a,b,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csr_from_coo end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_to_fmt - interface - subroutine psb_d_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_d_mv_csr_to_fmt(a,b,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csr_to_fmt end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt - interface - subroutine psb_d_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_d_mv_csr_from_fmt(a,b,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_mv_csr_from_fmt end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cp_from - interface + interface subroutine psb_d_csr_cp_from(a,b) import class(psb_d_csr_sparse_mat), intent(inout) :: a type(psb_d_csr_sparse_mat), intent(in) :: b end subroutine psb_d_csr_cp_from end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_mv_from - interface + interface subroutine psb_d_csr_mv_from(a,b) import class(psb_d_csr_sparse_mat), intent(inout) :: a type(psb_d_csr_sparse_mat), intent(inout) :: b end subroutine psb_d_csr_mv_from end interface - - + + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csput_a - interface - subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -395,10 +395,10 @@ module psb_d_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_csput_a end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -413,10 +413,10 @@ module psb_d_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_csr_csgetptn end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csgetrow - interface + interface subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import @@ -435,8 +435,8 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssv - interface - subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -447,8 +447,8 @@ module psb_d_csr_mat_mod end interface !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssm - interface - subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -457,11 +457,11 @@ module psb_d_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_csr_cssm end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csmv - interface - subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -473,8 +473,8 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csmm - interface - subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -483,32 +483,32 @@ module psb_d_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_csr_csmm end interface - - + + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_maxval - interface + interface function psb_d_csr_maxval(a) result(res) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csr_maxval end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_csnmi - interface + interface function psb_d_csr_csnmi(a) result(res) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csr_csnmi end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_rowsum - interface - subroutine psb_d_csr_rowsum(d,a) + interface + subroutine psb_d_csr_rowsum(d,a) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -517,18 +517,18 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_arwsum - interface - subroutine psb_d_csr_arwsum(d,a) + interface + subroutine psb_d_csr_arwsum(d,a) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csr_arwsum end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_colsum - interface - subroutine psb_d_csr_colsum(d,a) + interface + subroutine psb_d_csr_colsum(d,a) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -537,29 +537,29 @@ module psb_d_csr_mat_mod !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_aclsum - interface - subroutine psb_d_csr_aclsum(d,a) + interface + subroutine psb_d_csr_aclsum(d,a) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csr_aclsum end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_get_diag - interface - subroutine psb_d_csr_get_diag(a,d,info) + interface + subroutine psb_d_csr_get_diag(a,d,info) import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_get_diag end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scal - interface - subroutine psb_d_csr_scal(d,a,info,side) + interface + subroutine psb_d_csr_scal(d,a,info,side) import class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) @@ -567,32 +567,31 @@ module psb_d_csr_mat_mod character, intent(in), optional :: side end subroutine psb_d_csr_scal end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_scals interface - subroutine psb_d_csr_scals(d,a,info) + subroutine psb_d_csr_scals(d,a,info) import class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_scals end interface - !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat - !! + !! !! psb_ld_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_ld_base_sparse_mat) :: psb_ld_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_lpk_), allocatable :: irp(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_dpk_), allocatable :: val(:) contains @@ -642,23 +641,23 @@ module psb_d_csr_mat_mod !> \memberof psb_ld_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_ld_csr_reallocate_nz(nz,a) + subroutine psb_ld_csr_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_ld_csr_sparse_mat), intent(inout) :: a end subroutine psb_ld_csr_reallocate_nz end interface - + !> \memberof psb_ld_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_ld_csr_reinit(a,clear) import - class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ld_csr_reinit end interface - + !> \memberof psb_ld_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -668,22 +667,22 @@ module psb_d_csr_mat_mod end subroutine psb_ld_csr_trim end interface - + !> \memberof psb_ld_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ld_csr_mold(a,b,info) + interface + subroutine psb_ld_csr_mold(a,b,info) import class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csr_mold end interface - + !> \memberof psb_ld_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_ld_csr_sparse_mat), intent(inout) :: a @@ -691,14 +690,14 @@ module psb_d_csr_mat_mod end subroutine psb_ld_csr_allocate_mnnz end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_print interface subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -717,27 +716,27 @@ module psb_d_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ld_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -746,13 +745,13 @@ module psb_d_csr_mat_mod class(psb_ld_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_ld_csr_tril end interface - + ! !> Function triu: !! \memberof psb_d_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -761,27 +760,27 @@ module psb_d_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ld_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -792,133 +791,133 @@ module psb_d_csr_mat_mod end interface ! - !> + !> !! \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros ! interface subroutine psb_ld_csr_clean_zeros(a, info) - import + import class(psb_ld_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csr_clean_zeros end interface - - + + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo - interface - subroutine psb_ld_cp_csr_to_coo(a,b,info) + interface + subroutine psb_ld_cp_csr_to_coo(a,b,info) import class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csr_to_coo end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo - interface - subroutine psb_ld_cp_csr_from_coo(a,b,info) + interface + subroutine psb_ld_cp_csr_from_coo(a,b,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csr_from_coo end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt - interface - subroutine psb_ld_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_ld_cp_csr_to_fmt(a,b,info) import class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csr_to_fmt end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt - interface - subroutine psb_ld_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_ld_cp_csr_from_fmt(a,b,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_cp_csr_from_fmt end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo - interface - subroutine psb_ld_mv_csr_to_coo(a,b,info) + interface + subroutine psb_ld_mv_csr_to_coo(a,b,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csr_to_coo end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo - interface - subroutine psb_ld_mv_csr_from_coo(a,b,info) + interface + subroutine psb_ld_mv_csr_from_coo(a,b,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csr_from_coo end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt - interface - subroutine psb_ld_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_ld_mv_csr_to_fmt(a,b,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csr_to_fmt end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt - interface - subroutine psb_ld_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_ld_mv_csr_from_fmt(a,b,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_mv_csr_from_fmt end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from - interface + interface subroutine psb_ld_csr_cp_from(a,b) import class(psb_ld_csr_sparse_mat), intent(inout) :: a type(psb_ld_csr_sparse_mat), intent(in) :: b end subroutine psb_ld_csr_cp_from end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from - interface + interface subroutine psb_ld_csr_mv_from(a,b) import class(psb_ld_csr_sparse_mat), intent(inout) :: a type(psb_ld_csr_sparse_mat), intent(inout) :: b end subroutine psb_ld_csr_mv_from end interface - - + + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a - interface - subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -927,10 +926,10 @@ module psb_d_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csr_csput_a end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -945,10 +944,10 @@ module psb_d_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csr_csgetptn end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow - interface + interface subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -964,11 +963,11 @@ module psb_d_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csr_csgetrow end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag - interface - subroutine psb_ld_csr_get_diag(a,d,info) + interface + subroutine psb_ld_csr_get_diag(a,d,info) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -978,8 +977,8 @@ module psb_d_csr_mat_mod !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scal - interface - subroutine psb_ld_csr_scal(d,a,info,side) + interface + subroutine psb_ld_csr_scal(d,a,info,side) import class(psb_ld_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) @@ -987,42 +986,42 @@ module psb_d_csr_mat_mod character, intent(in), optional :: side end subroutine psb_ld_csr_scal end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_ld_base_mat_mod::psb_ld_base_scals interface - subroutine psb_ld_csr_scals(d,a,info) + subroutine psb_ld_csr_scals(d,a,info) import class(psb_ld_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csr_scals end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_maxval - interface + interface function psb_ld_csr_maxval(a) result(res) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_csr_maxval end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_csnmi - interface + interface function psb_ld_csr_csnmi(a) result(res) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_csr_csnmi end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_rowsum - interface - subroutine psb_ld_csr_rowsum(d,a) + interface + subroutine psb_ld_csr_rowsum(d,a) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -1031,18 +1030,18 @@ module psb_d_csr_mat_mod !> \memberof psb_ld_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_arwsum - interface - subroutine psb_ld_csr_arwsum(d,a) + interface + subroutine psb_ld_csr_arwsum(d,a) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_csr_arwsum end interface - + !> \memberof psb_ld_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_colsum - interface - subroutine psb_ld_csr_colsum(d,a) + interface + subroutine psb_ld_csr_colsum(d,a) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) @@ -1051,22 +1050,22 @@ module psb_d_csr_mat_mod !> \memberof psb_ld_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_ld_base_aclsum - interface - subroutine psb_ld_csr_aclsum(d,a) + interface + subroutine psb_ld_csr_aclsum(d,a) import class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_ld_csr_aclsum end interface - -contains + +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1075,54 +1074,54 @@ contains ! == =================================== - + function d_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function d_csr_is_by_rows - + function d_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function d_csr_sizeof function d_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function d_csr_get_fmt - + function d_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%irp(a%get_nrows()+1)-1 end function d_csr_get_nzeros function d_csr_get_size(a) result(res) - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1134,17 +1133,17 @@ contains function d_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function d_csr_get_nz_row @@ -1159,10 +1158,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine d_csr_free(a) - implicit none + subroutine d_csr_free(a) + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a @@ -1172,18 +1171,18 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine d_csr_free - + ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1192,54 +1191,54 @@ contains ! == =================================== - + function ld_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function ld_csr_is_by_rows - + function ld_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 2 * psb_sizeof_lp + res = 2 * psb_sizeof_lp res = res + psb_sizeof_dp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%irp) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function ld_csr_sizeof function ld_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function ld_csr_get_fmt - + function ld_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%irp(a%get_nrows()+1)-1 end function ld_csr_get_nzeros function ld_csr_get_size(a) result(res) - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1251,17 +1250,17 @@ contains function ld_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function ld_csr_get_nz_row @@ -1276,10 +1275,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine ld_csr_free(a) - implicit none + subroutine ld_csr_free(a) + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a @@ -1289,7 +1288,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine ld_csr_free diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 index b9abd069e..878d099f4 100644 --- a/base/modules/serial/psb_d_mat_mod.F90 +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_d_mat_mod ! @@ -37,7 +37,7 @@ ! provide a mean of switching, at run-time, among different formats, ! potentially unknown at the library compile-time by adding a layer of ! indirection. This type encapsulates the psb_d_base_sparse_mat class -! inside another class which is the one visible to the user. +! inside another class which is the one visible to the user. ! Most methods of the psb_d_mat_mod simply call the methods of the ! encapsulated class. ! The exceptions are mainly cscnv and cp_from/cp_to; these provide @@ -48,14 +48,14 @@ ! through the application life. ! In particular, computational methods can only be invoked when ! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the ! following state transition table. Associated with these states are ! the possible dynamic types of the inner matrix object. ! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method !| ---------------------------------- !| Null Build csall !| Build Build csput @@ -64,7 +64,7 @@ !| Assembled Update reinit !| Update Update csput !| Update Assembled cscnv -!| * unchanged reall +!| * unchanged reall !| Assembled Null free ! ! @@ -74,7 +74,7 @@ ! of the indices, which are PSB_LPK_ so that the entries ! are guaranteed to be able to contain global indices. ! This type only supports data handling and preprocessing, it is -! not supposed to be used for computations. +! not supposed to be used for computations. ! module psb_d_mat_mod @@ -84,7 +84,7 @@ module psb_d_mat_mod type :: psb_dspmat_type - class(psb_d_base_sparse_mat), allocatable :: a + class(psb_d_base_sparse_mat), allocatable :: a contains ! Getters @@ -126,12 +126,12 @@ module psb_d_mat_mod procedure, pass(a) :: set_unit => psb_d_set_unit procedure, pass(a) :: set_repeatable_updates => psb_d_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_d_csall procedure, pass(a) :: free => psb_d_free procedure, pass(a) :: trim => psb_d_trim procedure, pass(a) :: csput_a => psb_d_csput_a - procedure, pass(a) :: csput_v => psb_d_csput_v + procedure, pass(a) :: csput_v => psb_d_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_d_csgetptn procedure, pass(a) :: csgetrow => psb_d_csgetrow @@ -141,7 +141,7 @@ module psb_d_mat_mod procedure, pass(a) :: lcsgetptn => psb_d_lcsgetptn procedure, pass(a) :: lcsgetrow => psb_d_lcsgetrow generic, public :: csget => lcsgetptn, lcsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_d_tril procedure, pass(a) :: triu => psb_d_triu procedure, pass(a) :: m_csclip => psb_d_csclip @@ -169,7 +169,7 @@ module psb_d_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => d_mat_sync procedure, pass(a) :: is_host => d_mat_is_host @@ -205,16 +205,16 @@ module psb_d_mat_mod procedure, pass(a) :: mv_to_lb => psb_d_mv_to_lb procedure, pass(a) :: cp_from_lb => psb_d_cp_from_lb procedure, pass(a) :: cp_to_lb => psb_d_cp_to_lb - procedure, pass(a) :: mv_from_l => psb_d_mv_from_l - procedure, pass(a) :: mv_to_l => psb_d_mv_to_l - procedure, pass(a) :: cp_from_l => psb_d_cp_from_l - procedure, pass(a) :: cp_to_l => psb_d_cp_to_l + procedure, pass(a) :: mv_from_l => psb_d_mv_from_l + procedure, pass(a) :: mv_to_l => psb_d_mv_to_l + procedure, pass(a) :: cp_from_l => psb_d_cp_from_l + procedure, pass(a) :: cp_to_l => psb_d_cp_to_l generic, public :: mv_from => mv_from_lb, mv_from_l generic, public :: mv_to => mv_to_lb, mv_to_l generic, public :: cp_from => cp_from_lb, cp_from_l generic, public :: cp_to => cp_to_lb, cp_to_l - - ! Computational routines + + ! Computational routines procedure, pass(a) :: get_diag => psb_d_get_diag procedure, pass(a) :: maxval => psb_d_maxval procedure, pass(a) :: spnmi => psb_d_csnmi @@ -234,6 +234,11 @@ module psb_d_mat_mod procedure, pass(a) :: cssv => psb_d_cssv procedure, pass(a) :: cssm => psb_d_cssm generic, public :: spsm => cssm, cssv, cssv_v + procedure, pass(a) :: scalpid => psb_d_scalplusidentity + procedure, pass(a) :: spaxpby => psb_d_spaxpby + procedure, pass(a) :: cmpval => psb_d_cmpval + procedure, pass(a) :: cmpmat => psb_d_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_dspmat_type @@ -267,7 +272,7 @@ module psb_d_mat_mod type :: psb_ldspmat_type - class(psb_ld_base_sparse_mat), allocatable :: a + class(psb_ld_base_sparse_mat), allocatable :: a contains ! Getters @@ -296,7 +301,7 @@ module psb_d_mat_mod ! Setters procedure, pass(a) :: set_lnrows => psb_ld_set_lnrows procedure, pass(a) :: set_lncols => psb_ld_set_lncols -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) procedure, pass(a) :: set_inrows => psb_ld_set_inrows procedure, pass(a) :: set_incols => psb_ld_set_incols generic, public :: set_nrows => set_inrows, set_lnrows @@ -305,7 +310,7 @@ module psb_d_mat_mod generic, public :: set_nrows => set_lnrows generic, public :: set_ncols => set_lncols #endif - + procedure, pass(a) :: set_dupl => psb_ld_set_dupl procedure, pass(a) :: set_null => psb_ld_set_null procedure, pass(a) :: set_bld => psb_ld_set_bld @@ -319,12 +324,12 @@ module psb_d_mat_mod procedure, pass(a) :: set_unit => psb_ld_set_unit procedure, pass(a) :: set_repeatable_updates => psb_ld_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_ld_csall procedure, pass(a) :: free => psb_ld_free procedure, pass(a) :: trim => psb_ld_trim procedure, pass(a) :: csput_a => psb_ld_csput_a - procedure, pass(a) :: csput_v => psb_ld_csput_v + procedure, pass(a) :: csput_v => psb_ld_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_ld_csgetptn procedure, pass(a) :: csgetrow => psb_ld_csgetrow @@ -334,7 +339,7 @@ module psb_d_mat_mod !!$ procedure, pass(a) :: icsgetptn => psb_ld_icsgetptn !!$ procedure, pass(a) :: icsgetrow => psb_ld_icsgetrow !!$ generic, public :: csget => icsgetptn, icsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_ld_tril procedure, pass(a) :: triu => psb_ld_triu procedure, pass(a) :: m_csclip => psb_ld_csclip @@ -362,7 +367,7 @@ module psb_d_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => ld_mat_sync procedure, pass(a) :: is_host => ld_mat_is_host @@ -398,16 +403,16 @@ module psb_d_mat_mod procedure, pass(a) :: mv_to_ib => psb_ld_mv_to_ib procedure, pass(a) :: cp_from_ib => psb_ld_cp_from_ib procedure, pass(a) :: cp_to_ib => psb_ld_cp_to_ib - procedure, pass(a) :: mv_from_i => psb_ld_mv_from_i - procedure, pass(a) :: mv_to_i => psb_ld_mv_to_i - procedure, pass(a) :: cp_from_i => psb_ld_cp_from_i - procedure, pass(a) :: cp_to_i => psb_ld_cp_to_i + procedure, pass(a) :: mv_from_i => psb_ld_mv_from_i + procedure, pass(a) :: mv_to_i => psb_ld_mv_to_i + procedure, pass(a) :: cp_from_i => psb_ld_cp_from_i + procedure, pass(a) :: cp_to_i => psb_ld_cp_to_i generic, public :: mv_from => mv_from_ib, mv_from_i generic, public :: mv_to => mv_to_ib, mv_to_i generic, public :: cp_from => cp_from_ib, cp_from_i generic, public :: cp_to => cp_to_ib, cp_to_i - ! Computational routines + ! Computational routines procedure, pass(a) :: get_diag => psb_ld_get_diag procedure, pass(a) :: maxval => psb_ld_maxval procedure, pass(a) :: spnmi => psb_ld_csnmi @@ -419,6 +424,11 @@ module psb_d_mat_mod procedure, pass(a) :: scals => psb_ld_scals procedure, pass(a) :: scalv => psb_ld_scal generic, public :: scal => scals, scalv + procedure, pass(a) :: scalpid => psb_ld_scalplusidentity + procedure, pass(a) :: spaxpby => psb_ld_spaxpby + procedure, pass(a) :: cmpval => psb_ld_cmpval + procedure, pass(a) :: cmpmat => psb_ld_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_ldspmat_type @@ -449,7 +459,7 @@ module psb_d_mat_mod ! ! ! - ! Setters + ! Setters ! ! ! @@ -459,142 +469,142 @@ module psb_d_mat_mod ! == =================================== - interface - subroutine psb_d_set_nrows(m,a) + interface + subroutine psb_d_set_nrows(m,a) import :: psb_ipk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_d_set_nrows end interface - - interface - subroutine psb_d_set_ncols(n,a) + + interface + subroutine psb_d_set_ncols(n,a) import :: psb_ipk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_d_set_ncols end interface - - interface - subroutine psb_d_set_dupl(n,a) + + interface + subroutine psb_d_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_d_set_dupl end interface - - interface - subroutine psb_d_set_null(a) + + interface + subroutine psb_d_set_null(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_null end interface - - interface - subroutine psb_d_set_bld(a) + + interface + subroutine psb_d_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_bld end interface - - interface - subroutine psb_d_set_upd(a) + + interface + subroutine psb_d_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_upd end interface - - interface - subroutine psb_d_set_asb(a) + + interface + subroutine psb_d_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_set_asb end interface - - interface - subroutine psb_d_set_sorted(a,val) + + interface + subroutine psb_d_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_sorted end interface - - interface - subroutine psb_d_set_triangle(a,val) + + interface + subroutine psb_d_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_triangle end interface - - interface - subroutine psb_d_set_symmetric(a,val) + + interface + subroutine psb_d_set_symmetric(a,val) import :: psb_ipk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_symmetric end interface - - interface - subroutine psb_d_set_unit(a,val) + + interface + subroutine psb_d_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_unit end interface - - interface - subroutine psb_d_set_lower(a,val) + + interface + subroutine psb_d_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_lower end interface - - interface - subroutine psb_d_set_upper(a,val) + + interface + subroutine psb_d_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_d_set_upper end interface - - interface + + interface subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_dspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_d_sparse_print end interface - interface + interface subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_dspmat_type character(len=*), intent(in) :: fname - class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_d_n_sparse_print end interface - - interface + + interface subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_dspmat_type - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev end subroutine psb_d_get_neigh end interface - - interface - subroutine psb_d_csall(nr,nc,a,info,nz) + + interface + subroutine psb_d_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc @@ -602,31 +612,31 @@ module psb_d_mat_mod integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_d_csall end interface - - interface - subroutine psb_d_reallocate_nz(nz,a) + + interface + subroutine psb_d_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_reallocate_nz end interface - - interface - subroutine psb_d_free(a) + + interface + subroutine psb_d_free(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_free end interface - - interface - subroutine psb_d_trim(a) + + interface + subroutine psb_d_trim(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_trim end interface - - interface - subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -635,9 +645,9 @@ module psb_d_mat_mod end subroutine psb_d_csput_a end interface - - interface - subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_vect_mod, only : psb_d_vect_type use psb_i_vect_mod, only : psb_i_vect_type import :: psb_ipk_, psb_lpk_, psb_dspmat_type @@ -648,8 +658,8 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csput_v end interface - - interface + + interface subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -664,8 +674,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_csgetptn end interface - - interface + + interface subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -681,8 +691,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_csgetrow end interface - - interface + + interface subroutine psb_d_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -696,8 +706,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_csgetblk end interface - - interface + + interface subroutine psb_d_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -709,8 +719,8 @@ module psb_d_mat_mod class(psb_dspmat_type), optional, intent(inout) :: u end subroutine psb_d_tril end interface - - interface + + interface subroutine psb_d_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -724,7 +734,7 @@ module psb_d_mat_mod end interface - interface + interface subroutine psb_d_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -736,7 +746,7 @@ module psb_d_mat_mod end subroutine psb_d_csclip end interface - interface + interface subroutine psb_d_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -746,8 +756,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_csclip_ip end interface - - interface + + interface subroutine psb_d_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_coo_sparse_mat @@ -758,60 +768,60 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_d_b_csclip end interface - - interface + + interface subroutine psb_d_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_d_mold end interface - - interface - subroutine psb_d_asb(a,mold) + + interface + subroutine psb_d_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_d_asb end interface - - interface + + interface subroutine psb_d_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_transp_1mat end interface - - interface + + interface subroutine psb_d_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b end subroutine psb_d_transp_2mat end interface - - interface + + interface subroutine psb_d_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a end subroutine psb_d_transc_1mat end interface - - interface + + interface subroutine psb_d_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b end subroutine psb_d_transc_2mat end interface - - interface + + interface subroutine psb_d_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_reinit - + end interface @@ -826,9 +836,9 @@ module psb_d_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(in) :: a @@ -839,9 +849,9 @@ module psb_d_mat_mod class(psb_d_base_sparse_mat), intent(in), optional :: mold end subroutine psb_d_cscnv end interface - - interface + + interface subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a @@ -851,9 +861,9 @@ module psb_d_mat_mod class(psb_d_base_sparse_mat), intent(in), optional :: mold end subroutine psb_d_cscnv_ip end interface - - interface + + interface subroutine psb_d_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(in) :: a @@ -862,12 +872,12 @@ module psb_d_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_d_cscnv_base end interface - + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_d_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(in) :: a @@ -875,46 +885,46 @@ module psb_d_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_d_clip_d end interface - - interface + + interface subroutine psb_d_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_d_clip_d_ip end interface - + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_d_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_d_mv_from end interface - - interface + + interface subroutine psb_d_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(out) :: a class(psb_d_base_sparse_mat), intent(in) :: b end subroutine psb_d_cp_from end interface - - interface + + interface subroutine psb_d_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_d_mv_to end interface - - interface + + interface subroutine psb_d_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_d_cp_to @@ -922,63 +932,63 @@ module psb_d_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_d_mv_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_d_mv_from_lb end interface - - interface + + interface subroutine psb_d_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_dspmat_type), intent(out) :: a class(psb_ld_base_sparse_mat), intent(in) :: b end subroutine psb_d_cp_from_lb end interface - - interface + + interface subroutine psb_d_mv_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_d_mv_to_lb end interface - - interface + + interface subroutine psb_d_cp_to_lb(a,b) - import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_dspmat_type), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_d_cp_to_lb end interface - interface + interface subroutine psb_d_mv_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type class(psb_dspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: b end subroutine psb_d_mv_from_l end interface - - interface + + interface subroutine psb_d_cp_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type class(psb_dspmat_type), intent(out) :: a class(psb_ldspmat_type), intent(in) :: b end subroutine psb_d_cp_from_l end interface - - interface + + interface subroutine psb_d_mv_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type class(psb_dspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: b end subroutine psb_d_mv_to_l end interface - - interface + + interface subroutine psb_d_cp_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type class(psb_dspmat_type), intent(in) :: a @@ -988,8 +998,8 @@ module psb_d_mat_mod ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_dspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a @@ -997,8 +1007,8 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_dspmat_type_move end interface - - interface + + interface subroutine psb_dspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_dspmat_type class(psb_dspmat_type), intent(inout) :: a @@ -1024,7 +1034,7 @@ module psb_d_mat_mod ! == =================================== interface psb_csmm - subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) + subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1032,7 +1042,7 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_d_csmm - subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -1040,7 +1050,7 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_d_csmv - subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) + subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_d_vect_mod, only : psb_d_vect_type import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1051,9 +1061,9 @@ module psb_d_mat_mod character, optional, intent(in) :: trans end subroutine psb_d_csmv_vect end interface - + interface psb_cssm - subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1062,7 +1072,7 @@ module psb_d_mat_mod character, optional, intent(in) :: trans, scale real(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_d_cssm - subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -1071,7 +1081,7 @@ module psb_d_mat_mod character, optional, intent(in) :: trans, scale real(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_d_cssv - subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_d_vect_mod, only : psb_d_vect_type import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1083,24 +1093,24 @@ module psb_d_mat_mod type(psb_d_vect_type), optional, intent(inout) :: d end subroutine psb_d_cssv_vect end interface - - interface + + interface function psb_d_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_d_maxval end interface - - interface + + interface function psb_d_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csnmi end interface - - interface + + interface function psb_d_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1108,7 +1118,7 @@ module psb_d_mat_mod end function psb_d_csnm1 end interface - interface + interface function psb_d_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1117,7 +1127,7 @@ module psb_d_mat_mod end function psb_d_rowsum end interface - interface + interface function psb_d_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1125,8 +1135,8 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_d_arwsum end interface - - interface + + interface function psb_d_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1135,7 +1145,7 @@ module psb_d_mat_mod end function psb_d_colsum end interface - interface + interface function psb_d_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1144,7 +1154,7 @@ module psb_d_mat_mod end function psb_d_aclsum end interface - interface + interface function psb_d_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ class(psb_dspmat_type), intent(in) :: a @@ -1152,7 +1162,7 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_d_get_diag end interface - + interface psb_scal subroutine psb_d_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ @@ -1169,12 +1179,53 @@ module psb_d_mat_mod end subroutine psb_d_scals end interface + interface psb_scalplusidentity + subroutine psb_d_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_d_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_spaxpby + end interface + + interface + function psb_d_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_d_cmpval + end interface + + interface + function psb_d_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_d_cmpmat + end interface ! == =================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -1184,156 +1235,156 @@ module psb_d_mat_mod ! == =================================== - interface - subroutine psb_ld_set_lnrows(m,a) + interface + subroutine psb_ld_set_lnrows(m,a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m end subroutine psb_ld_set_lnrows #if defined(IPK4) && defined(LPK8) - subroutine psb_ld_set_inrows(m,a) + subroutine psb_ld_set_inrows(m,a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_ld_set_inrows #endif end interface - - interface - subroutine psb_ld_set_lncols(n,a) + + interface + subroutine psb_ld_set_lncols(n,a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n end subroutine psb_ld_set_lncols -#if defined(IPK4) && defined(LPK8) - subroutine psb_ld_set_incols(n,a) +#if defined(IPK4) && defined(LPK8) + subroutine psb_ld_set_incols(n,a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_ld_set_incols #endif end interface - - interface - subroutine psb_ld_set_dupl(n,a) + + interface + subroutine psb_ld_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_ld_set_dupl end interface - - interface - subroutine psb_ld_set_null(a) + + interface + subroutine psb_ld_set_null(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_set_null end interface - - interface - subroutine psb_ld_set_bld(a) + + interface + subroutine psb_ld_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_set_bld end interface - - interface - subroutine psb_ld_set_upd(a) + + interface + subroutine psb_ld_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_set_upd end interface - - interface - subroutine psb_ld_set_asb(a) + + interface + subroutine psb_ld_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_set_asb end interface - - interface - subroutine psb_ld_set_sorted(a,val) + + interface + subroutine psb_ld_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ld_set_sorted end interface - - interface - subroutine psb_ld_set_triangle(a,val) + + interface + subroutine psb_ld_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ld_set_triangle end interface - - interface - subroutine psb_ld_set_symmetric(a,val) + + interface + subroutine psb_ld_set_symmetric(a,val) import :: psb_ipk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ld_set_symmetric end interface - - interface - subroutine psb_ld_set_unit(a,val) + + interface + subroutine psb_ld_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ld_set_unit end interface - - interface - subroutine psb_ld_set_lower(a,val) + + interface + subroutine psb_ld_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ld_set_lower end interface - - interface - subroutine psb_ld_set_upper(a,val) + + interface + subroutine psb_ld_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ld_set_upper end interface - - interface + + interface subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ld_sparse_print end interface - interface + interface subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type character(len=*), intent(in) :: fname - class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ld_n_sparse_print end interface - - interface + + interface subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev end subroutine psb_ld_get_neigh end interface - - interface - subroutine psb_ld_csall(nr,nc,a,info,nz) + + interface + subroutine psb_ld_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc @@ -1341,31 +1392,31 @@ module psb_d_mat_mod integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_ld_csall end interface - - interface - subroutine psb_ld_reallocate_nz(nz,a) + + interface + subroutine psb_ld_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type integer(psb_lpk_), intent(in) :: nz class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_reallocate_nz end interface - - interface - subroutine psb_ld_free(a) + + interface + subroutine psb_ld_free(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_free end interface - - interface - subroutine psb_ld_trim(a) + + interface + subroutine psb_ld_trim(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_trim end interface - - interface - subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -1374,9 +1425,9 @@ module psb_d_mat_mod end subroutine psb_ld_csput_a end interface - - interface - subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_vect_mod, only : psb_d_vect_type use psb_l_vect_mod, only : psb_l_vect_type import :: psb_ipk_, psb_lpk_, psb_ldspmat_type @@ -1387,8 +1438,8 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_csput_v end interface - - interface + + interface subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1403,8 +1454,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csgetptn end interface - - interface + + interface subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1420,8 +1471,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csgetrow end interface - - interface + + interface subroutine psb_ld_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1435,8 +1486,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csgetblk end interface - - interface + + interface subroutine psb_ld_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1448,8 +1499,8 @@ module psb_d_mat_mod class(psb_ldspmat_type), optional, intent(inout) :: u end subroutine psb_ld_tril end interface - - interface + + interface subroutine psb_ld_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1463,7 +1514,7 @@ module psb_d_mat_mod end interface - interface + interface subroutine psb_ld_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1475,7 +1526,7 @@ module psb_d_mat_mod end subroutine psb_ld_csclip end interface - interface + interface subroutine psb_ld_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1485,8 +1536,8 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_csclip_ip end interface - - interface + + interface subroutine psb_ld_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_coo_sparse_mat @@ -1497,60 +1548,60 @@ module psb_d_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ld_b_csclip end interface - - interface + + interface subroutine psb_ld_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_ld_mold end interface - - interface - subroutine psb_ld_asb(a,mold) + + interface + subroutine psb_ld_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_ld_asb end interface - - interface + + interface subroutine psb_ld_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_transp_1mat end interface - - interface + + interface subroutine psb_ld_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: b end subroutine psb_ld_transp_2mat end interface - - interface + + interface subroutine psb_ld_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a end subroutine psb_ld_transc_1mat end interface - - interface + + interface subroutine psb_ld_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: b end subroutine psb_ld_transc_2mat end interface - - interface + + interface subroutine psb_ld_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type - class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ld_reinit - + end interface @@ -1565,9 +1616,9 @@ module psb_d_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(in) :: a @@ -1578,9 +1629,9 @@ module psb_d_mat_mod class(psb_ld_base_sparse_mat), intent(in), optional :: mold end subroutine psb_ld_cscnv end interface - - interface + + interface subroutine psb_ld_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a @@ -1590,9 +1641,9 @@ module psb_d_mat_mod class(psb_ld_base_sparse_mat), intent(in), optional :: mold end subroutine psb_ld_cscnv_ip end interface - - interface + + interface subroutine psb_ld_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(in) :: a @@ -1601,13 +1652,13 @@ module psb_d_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_ld_cscnv_base end interface - - + + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_ld_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(in) :: a @@ -1615,47 +1666,47 @@ module psb_d_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_ld_clip_d end interface - - interface + + interface subroutine psb_ld_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_ld_clip_d_ip end interface - - + + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_ld_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_mv_from end interface - - interface + + interface subroutine psb_ld_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(out) :: a class(psb_ld_base_sparse_mat), intent(in) :: b end subroutine psb_ld_cp_from end interface - - interface + + interface subroutine psb_ld_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_mv_to end interface - - interface + + interface subroutine psb_ld_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat class(psb_ldspmat_type), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_cp_to @@ -1663,63 +1714,63 @@ module psb_d_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_ld_mv_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_mv_from_ib end interface - - interface + + interface subroutine psb_ld_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_ldspmat_type), intent(out) :: a class(psb_d_base_sparse_mat), intent(in) :: b end subroutine psb_ld_cp_from_ib end interface - - interface + + interface subroutine psb_ld_mv_to_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_ldspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_mv_to_ib end interface - - interface + + interface subroutine psb_ld_cp_to_ib(a,b) - import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat class(psb_ldspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b end subroutine psb_ld_cp_to_ib end interface - interface + interface subroutine psb_ld_mv_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type class(psb_ldspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b end subroutine psb_ld_mv_from_i end interface - - interface + + interface subroutine psb_ld_cp_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type class(psb_ldspmat_type), intent(out) :: a class(psb_dspmat_type), intent(in) :: b end subroutine psb_ld_cp_from_i end interface - - interface + + interface subroutine psb_ld_mv_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type class(psb_ldspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b end subroutine psb_ld_mv_to_i end interface - - interface + + interface subroutine psb_ld_cp_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type class(psb_ldspmat_type), intent(in) :: a @@ -1727,11 +1778,11 @@ module psb_d_mat_mod end subroutine psb_ld_cp_to_i end interface - + ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_ldspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a @@ -1739,8 +1790,8 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ldspmat_type_move end interface - - interface + + interface subroutine psb_ldspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type class(psb_ldspmat_type), intent(inout) :: a @@ -1751,7 +1802,7 @@ module psb_d_mat_mod - interface + interface function psb_ld_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a @@ -1759,7 +1810,7 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_ld_get_diag end interface - + interface psb_scal subroutine psb_ld_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ @@ -1776,23 +1827,43 @@ module psb_d_mat_mod end subroutine psb_ld_scals end interface - interface + interface psb_scalplusidentity + subroutine psb_ld_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_ld_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_spaxpby + end interface + + interface function psb_ld_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_maxval end interface - - interface + + interface function psb_ld_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_ld_csnmi end interface - - interface + + interface function psb_ld_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a @@ -1800,7 +1871,7 @@ module psb_d_mat_mod end function psb_ld_csnm1 end interface - interface + interface function psb_ld_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a @@ -1809,7 +1880,7 @@ module psb_d_mat_mod end function psb_ld_rowsum end interface - interface + interface function psb_ld_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a @@ -1817,8 +1888,8 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_ld_arwsum end interface - - interface + + interface function psb_ld_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a @@ -1827,7 +1898,7 @@ module psb_d_mat_mod end function psb_ld_colsum end interface - interface + interface function psb_ld_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ class(psb_ldspmat_type), intent(in) :: a @@ -1835,40 +1906,59 @@ module psb_d_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_ld_aclsum end interface - -contains - subroutine psb_d_set_mat_default(a) - implicit none + interface psb_cmpmat + function psb_ld_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ld_cmpval + function psb_ld_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ld_cmpmat + end interface + +contains + + subroutine psb_d_set_mat_default(a) + implicit none class(psb_d_base_sparse_mat), intent(in) :: a - - if (allocated(psb_d_base_mat_default)) then + + if (allocated(psb_d_base_mat_default)) then deallocate(psb_d_base_mat_default) end if allocate(psb_d_base_mat_default, mold=a) end subroutine psb_d_set_mat_default - + function psb_d_get_mat_default(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), pointer :: res - + res => psb_d_get_base_mat_default() - + end function psb_d_get_mat_default - + function psb_d_get_base_mat_default() result(res) - implicit none + implicit none class(psb_d_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_d_base_mat_default)) then + + if (.not.allocated(psb_d_base_mat_default)) then allocate(psb_d_csr_sparse_mat :: psb_d_base_mat_default) end if res => psb_d_base_mat_default - + end function psb_d_get_base_mat_default subroutine psb_d_clear_mat_default() @@ -1886,7 +1976,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1894,26 +1984,26 @@ contains ! ! == =================================== - + function psb_d_sizeof(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_d_sizeof function psb_d_get_fmt(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -1923,11 +2013,11 @@ contains function psb_d_get_dupl(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -1935,11 +2025,11 @@ contains end function psb_d_get_dupl function psb_d_get_nrows(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -1948,11 +2038,11 @@ contains end function psb_d_get_nrows function psb_d_get_ncols(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -1961,11 +2051,11 @@ contains end function psb_d_get_ncols function psb_d_is_triangle(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -1974,11 +2064,11 @@ contains end function psb_d_is_triangle function psb_d_is_symmetric(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -1987,11 +2077,11 @@ contains end function psb_d_is_symmetric function psb_d_is_unit(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2000,11 +2090,11 @@ contains end function psb_d_is_unit function psb_d_is_upper(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2013,11 +2103,11 @@ contains end function psb_d_is_upper function psb_d_is_lower(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2026,12 +2116,12 @@ contains end function psb_d_is_lower function psb_d_is_null(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2039,11 +2129,11 @@ contains end function psb_d_is_null function psb_d_is_bld(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2052,11 +2142,11 @@ contains end function psb_d_is_bld function psb_d_is_upd(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2065,11 +2155,11 @@ contains end function psb_d_is_upd function psb_d_is_asb(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2078,11 +2168,11 @@ contains end function psb_d_is_asb function psb_d_is_sorted(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2091,11 +2181,11 @@ contains end function psb_d_is_sorted function psb_d_is_by_rows(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2104,11 +2194,11 @@ contains end function psb_d_is_by_rows function psb_d_is_by_cols(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2119,61 +2209,61 @@ contains ! subroutine d_mat_sync(a) - implicit none + implicit none class(psb_dspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine d_mat_sync ! subroutine d_mat_set_host(a) - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine d_mat_set_host ! subroutine d_mat_set_dev(a) - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine d_mat_set_dev ! subroutine d_mat_set_sync(a) - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine d_mat_set_sync ! function d_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function d_mat_is_dev - + ! function d_mat_is_host(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2183,11 +2273,11 @@ contains ! function d_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2198,11 +2288,11 @@ contains function psb_d_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2210,25 +2300,25 @@ contains end function psb_d_is_repeatable_updates - subroutine psb_d_set_repeatable_updates(a,val) - implicit none + subroutine psb_d_set_repeatable_updates(a,val) + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_d_set_repeatable_updates function psb_d_get_nzeros(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2236,13 +2326,13 @@ contains function psb_d_get_size(a) result(res) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2250,23 +2340,23 @@ contains function psb_d_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_ipk_), intent(in) :: idx class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_d_get_nz_row subroutine psb_d_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_dspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_d_clean_zeros @@ -2274,7 +2364,7 @@ contains #if defined(IPK4) && defined(LPK8) subroutine psb_d_lcsgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2303,17 +2393,17 @@ contains end if call a%csget(imin,imax,nz,lia,lja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_d_lcsgetptn - + subroutine psb_d_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2342,12 +2432,12 @@ contains call a%csget(imin,imax,nz,lia,lja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_d_lcsgetrow #endif @@ -2355,38 +2445,38 @@ contains ! ld methods ! - - subroutine psb_ld_set_mat_default(a) - implicit none + + subroutine psb_ld_set_mat_default(a) + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a - - if (allocated(psb_ld_base_mat_default)) then + + if (allocated(psb_ld_base_mat_default)) then deallocate(psb_ld_base_mat_default) end if allocate(psb_ld_base_mat_default, mold=a) end subroutine psb_ld_set_mat_default - + function psb_ld_get_mat_default(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ld_base_sparse_mat), pointer :: res - + res => psb_ld_get_base_mat_default() - + end function psb_ld_get_mat_default - + function psb_ld_get_base_mat_default() result(res) - implicit none + implicit none class(psb_ld_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_ld_base_mat_default)) then + + if (.not.allocated(psb_ld_base_mat_default)) then allocate(psb_ld_csr_sparse_mat :: psb_ld_base_mat_default) end if res => psb_ld_base_mat_default - + end function psb_ld_get_base_mat_default subroutine psb_ld_clear_mat_default() @@ -2404,7 +2494,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -2412,26 +2502,26 @@ contains ! ! == =================================== - + function psb_ld_sizeof(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_ld_sizeof function psb_ld_get_fmt(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -2441,11 +2531,11 @@ contains function psb_ld_get_dupl(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -2453,11 +2543,11 @@ contains end function psb_ld_get_dupl function psb_ld_get_nrows(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -2466,11 +2556,11 @@ contains end function psb_ld_get_nrows function psb_ld_get_ncols(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -2479,11 +2569,11 @@ contains end function psb_ld_get_ncols function psb_ld_is_triangle(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -2493,11 +2583,11 @@ contains function psb_ld_is_symmetric(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -2506,11 +2596,11 @@ contains end function psb_ld_is_symmetric function psb_ld_is_unit(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2519,11 +2609,11 @@ contains end function psb_ld_is_unit function psb_ld_is_upper(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2532,11 +2622,11 @@ contains end function psb_ld_is_upper function psb_ld_is_lower(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2545,12 +2635,12 @@ contains end function psb_ld_is_lower function psb_ld_is_null(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2558,11 +2648,11 @@ contains end function psb_ld_is_null function psb_ld_is_bld(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2571,11 +2661,11 @@ contains end function psb_ld_is_bld function psb_ld_is_upd(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2584,11 +2674,11 @@ contains end function psb_ld_is_upd function psb_ld_is_asb(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2597,11 +2687,11 @@ contains end function psb_ld_is_asb function psb_ld_is_sorted(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2610,11 +2700,11 @@ contains end function psb_ld_is_sorted function psb_ld_is_by_rows(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2623,11 +2713,11 @@ contains end function psb_ld_is_by_rows function psb_ld_is_by_cols(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2638,61 +2728,61 @@ contains ! subroutine ld_mat_sync(a) - implicit none + implicit none class(psb_ldspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine ld_mat_sync ! subroutine ld_mat_set_host(a) - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine ld_mat_set_host ! subroutine ld_mat_set_dev(a) - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine ld_mat_set_dev ! subroutine ld_mat_set_sync(a) - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine ld_mat_set_sync ! function ld_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function ld_mat_is_dev - + ! function ld_mat_is_host(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2702,11 +2792,11 @@ contains ! function ld_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2717,11 +2807,11 @@ contains function psb_ld_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2729,25 +2819,25 @@ contains end function psb_ld_is_repeatable_updates - subroutine psb_ld_set_repeatable_updates(a,val) - implicit none + subroutine psb_ld_set_repeatable_updates(a,val) + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_ld_set_repeatable_updates function psb_ld_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2755,13 +2845,13 @@ contains function psb_ld_get_size(a) result(res) - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2769,23 +2859,23 @@ contains function psb_ld_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_lpk_), intent(in) :: idx class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_ld_get_nz_row subroutine psb_ld_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_ldspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_ld_clean_zeros @@ -2793,7 +2883,7 @@ contains #if defined(IPK4) && defined(LPK8) !!$ subroutine psb_ld_icsgetptn(imin,imax,a,nz,ia,ja,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_ldspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2829,12 +2919,12 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_ld_icsgetptn -!!$ +!!$ !!$ subroutine psb_ld_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_ldspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2870,7 +2960,7 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_ld_icsgetrow #endif diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 6d13b3ee3..0ce964992 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_d_vect_mod ! ! This module contains the definition of the psb_d_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_d_vect_mod @@ -43,7 +43,7 @@ module psb_d_vect_mod use psb_i_vect_mod type psb_d_vect_type - class(psb_d_base_vect_type), allocatable :: v + class(psb_d_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => d_vect_get_nrows procedure, pass(x) :: sizeof => d_vect_sizeof @@ -85,7 +85,9 @@ module psb_d_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => d_vect_axpby_v procedure, pass(y) :: axpby_a => d_vect_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => d_vect_axpby_v2 + procedure, pass(z) :: axpby_a2 => d_vect_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 procedure, pass(y) :: mlt_v => d_vect_mlt_v procedure, pass(y) :: mlt_a => d_vect_mlt_a procedure, pass(z) :: mlt_a_2 => d_vect_mlt_a_2 @@ -94,13 +96,44 @@ module psb_d_vect_mod procedure, pass(z) :: mlt_av => d_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => d_vect_div_v + procedure, pass(z) :: div_v2 => d_vect_div_v2 + procedure, pass(x) :: div_v_check => d_vect_div_v_check + procedure, pass(x) :: div_v2_check => d_vect_div_v2_check + procedure, pass(z) :: div_a2 => d_vect_div_a2 + procedure, pass(z) :: div_a2_check => d_vect_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => d_vect_inv_v + procedure, pass(y) :: inv_v_check => d_vect_inv_v_check + procedure, pass(y) :: inv_a2 => d_vect_inv_a2 + procedure, pass(y) :: inv_a2_check => d_vect_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check procedure, pass(x) :: scal => d_vect_scal procedure, pass(x) :: absval1 => d_vect_absval1 procedure, pass(x) :: absval2 => d_vect_absval2 generic, public :: absval => absval1, absval2 - procedure, pass(x) :: nrm2 => d_vect_nrm2 + procedure, pass(x) :: nrm2std => d_vect_nrm2 + procedure, pass(x) :: nrm2weight => d_vect_nrm2_weight + procedure, pass(x) :: nrm2weightmask => d_vect_nrm2_weight_mask + generic, public :: nrm2 => nrm2std, nrm2weight, nrm2weightmask procedure, pass(x) :: amax => d_vect_amax - procedure, pass(x) :: asum => d_vect_asum + procedure, pass(x) :: asum => d_vect_asum + procedure, pass(z) :: acmp_a2 => d_vect_acmp_a2 + procedure, pass(z) :: acmp_v2 => d_vect_acmp_v2 + generic, public :: acmp => acmp_a2, acmp_v2 + procedure, pass(z) :: addconst_a2 => d_vect_addconst_a2 + procedure, pass(z) :: addconst_v2 => d_vect_addconst_v2 + generic, public :: addconst => addconst_a2, addconst_v2 + + procedure, pass(x) :: minreal => d_vect_min + procedure, pass(m) :: mask_v => d_vect_mask_v + procedure, pass(m) :: mask_a => d_vect_mask_a + generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => d_vect_minquotient_v + procedure, pass(x) :: minquotient_a2 => d_vect_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 + end type psb_d_vect_type public :: psb_d_vect @@ -122,8 +155,7 @@ module psb_d_vect_mod private :: d_vect_dot_v, d_vect_dot_a, d_vect_axpby_v, d_vect_axpby_a, & & d_vect_mlt_v, d_vect_mlt_a, d_vect_mlt_a_2, d_vect_mlt_v_2, & & d_vect_mlt_va, d_vect_mlt_av, d_vect_scal, d_vect_absval1, & - & d_vect_absval2, d_vect_nrm2, d_vect_amax, d_vect_asum - + & d_vect_absval2, d_vect_nrm2, d_vect_amax, d_vect_asum class(psb_d_base_vect_type), allocatable, target,& @@ -141,11 +173,11 @@ module psb_d_vect_mod contains - subroutine psb_d_set_vect_default(v) - implicit none + subroutine psb_d_set_vect_default(v) + implicit none class(psb_d_base_vect_type), intent(in) :: v - if (allocated(psb_d_base_vect_default)) then + if (allocated(psb_d_base_vect_default)) then deallocate(psb_d_base_vect_default) end if allocate(psb_d_base_vect_default, mold=v) @@ -153,7 +185,7 @@ contains end subroutine psb_d_set_vect_default function psb_d_get_vect_default(v) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: v class(psb_d_base_vect_type), pointer :: res @@ -171,10 +203,10 @@ contains end subroutine psb_d_clear_vect_default function psb_d_get_base_vect_default() result(res) - implicit none + implicit none class(psb_d_base_vect_type), pointer :: res - if (.not.allocated(psb_d_base_vect_default)) then + if (.not.allocated(psb_d_base_vect_default)) then allocate(psb_d_base_vect_type :: psb_d_base_vect_default) end if @@ -183,14 +215,14 @@ contains end function psb_d_get_base_vect_default subroutine d_vect_clone(x,y,info) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine d_vect_clone @@ -205,7 +237,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) @@ -227,7 +259,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) @@ -247,7 +279,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) @@ -310,7 +342,7 @@ contains end function size_const function d_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -318,7 +350,7 @@ contains end function d_vect_get_nrows function d_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -326,7 +358,7 @@ contains end function d_vect_sizeof function d_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -335,7 +367,7 @@ contains subroutine d_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold @@ -344,12 +376,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_d_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -359,12 +391,12 @@ contains subroutine d_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -374,7 +406,7 @@ contains subroutine d_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -384,7 +416,7 @@ contains subroutine d_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -430,12 +462,12 @@ contains subroutine d_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -444,7 +476,7 @@ contains subroutine d_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -454,7 +486,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -465,7 +497,7 @@ contains subroutine d_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -475,7 +507,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -493,12 +525,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_d_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -509,7 +541,7 @@ contains subroutine d_vect_sync(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -518,7 +550,7 @@ contains end subroutine d_vect_sync subroutine d_vect_set_sync(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -527,7 +559,7 @@ contains end subroutine d_vect_set_sync subroutine d_vect_set_host(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -536,7 +568,7 @@ contains end subroutine d_vect_set_host subroutine d_vect_set_dev(x) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -545,7 +577,7 @@ contains end subroutine d_vect_set_dev function d_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x @@ -556,7 +588,7 @@ contains end function d_vect_is_sync function d_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x @@ -567,11 +599,11 @@ contains end function d_vect_is_host function d_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_d_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -579,7 +611,7 @@ contains function d_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res @@ -591,7 +623,7 @@ contains end function d_vect_dot_v function d_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -605,14 +637,14 @@ contains subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y real(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -620,9 +652,27 @@ contains end subroutine d_vect_axpby_v + subroutine d_vect_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine d_vect_axpby_v2 + subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent(in) :: x(:) class(psb_d_vect_type), intent(inout) :: y @@ -634,13 +684,27 @@ contains end subroutine d_vect_axpby_a + subroutine d_vect_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine d_vect_axpby_a2 subroutine d_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -651,7 +715,7 @@ contains subroutine d_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: x(:) class(psb_d_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -667,7 +731,7 @@ contains subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) real(psb_dpk_), intent(in) :: x(:) @@ -675,7 +739,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -683,12 +747,12 @@ contains subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -702,12 +766,12 @@ contains subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: x(:) class(psb_d_vect_type), intent(inout) :: y class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -718,12 +782,12 @@ contains subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_dpk_), intent(in) :: alpha,beta real(psb_dpk_), intent(in) :: y(:) class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -733,9 +797,186 @@ contains end subroutine d_vect_mlt_va + subroutine d_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine d_vect_div_v + + subroutine d_vect_div_v2( x, y, z, info) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine d_vect_div_v2 + + subroutine d_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine d_vect_div_v_check + + subroutine d_vect_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine d_vect_div_v2_check + + subroutine d_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine d_vect_div_a2 + + subroutine d_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine d_vect_div_a2_check + + subroutine d_vect_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine d_vect_inv_v + + subroutine d_vect_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine d_vect_inv_v_check + + subroutine d_vect_inv_a2(x, y, info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine d_vect_inv_a2 + + subroutine d_vect_inv_a2_check(x, y, info,flag) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine d_vect_inv_a2_check + + subroutine d_vect_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine d_vect_acmp_a2 + + subroutine d_vect_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine d_vect_acmp_v2 + subroutine d_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent (in) :: alpha @@ -755,19 +996,19 @@ contains class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine d_vect_absval2 function d_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = dzero @@ -775,13 +1016,49 @@ contains end function d_vect_nrm2 + function d_vect_nrm2_weight(n,x,w) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: w + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v)) then + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = dzero + end if + + end function d_vect_nrm2_weight + + function d_vect_nrm2_weight_mask(n,x,w,id) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: w + class(psb_d_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v).and.allocated(id%v)) then + where( abs(id%v%v) <= dzero) x%v%v = dzero + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = dzero + end if + + end function d_vect_nrm2_weight_mask + function d_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = dzero @@ -789,13 +1066,27 @@ contains end function d_vect_amax - function d_vect_asum(n,x) result(res) - implicit none + function d_vect_min(n,x) result(res) + implicit none class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then + res = x%v%minreal(n) + else + res = dzero + end if + + end function d_vect_min + + function d_vect_asum(n,x) result(res) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + + if (allocated(x%v)) then res = x%v%asum(n) else res = dzero @@ -804,6 +1095,94 @@ contains end function d_vect_asum + subroutine d_vect_mask_a(c,x,m,t,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(inout) :: c(:) + real(psb_dpk_), intent(inout) :: x(:) + logical, intent(out) :: t; + class(psb_d_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(m%v)) & + & call m%mask(c,x,t,info) + + end subroutine d_vect_mask_a + + subroutine d_vect_mask_v(c,x,m,t,info) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: c + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: m + logical, intent(out) :: t; + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(c%v)) & + & call m%v%mask(x%v,c%v,t,info) + + end subroutine d_vect_mask_v + + function d_vect_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: y + real(psb_dpk_) :: z + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & z = x%v%minquotient(y%v,info) + + end function d_vect_minquotient_v + + function d_vect_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_d_vect_type), intent(inout) :: x + real(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: z + + info = 0 + z = x%v%minquotient(y,info) + + end function d_vect_minquotient_a2 + + + + subroutine d_vect_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: b + real(psb_dpk_), intent(inout) :: x(:) + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine d_vect_addconst_a2 + + subroutine d_vect_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: b + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine d_vect_addconst_v2 + end module psb_d_vect_mod @@ -818,7 +1197,7 @@ module psb_d_multivect_mod !private type psb_d_multivect_type - class(psb_d_base_multivect_type), allocatable :: v + class(psb_d_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => d_vect_get_nrows procedure, pass(x) :: get_ncols => d_vect_get_ncols @@ -892,11 +1271,11 @@ module psb_d_multivect_mod contains - subroutine psb_d_set_multivect_default(v) - implicit none + subroutine psb_d_set_multivect_default(v) + implicit none class(psb_d_base_multivect_type), intent(in) :: v - if (allocated(psb_d_base_multivect_default)) then + if (allocated(psb_d_base_multivect_default)) then deallocate(psb_d_base_multivect_default) end if allocate(psb_d_base_multivect_default, mold=v) @@ -904,7 +1283,7 @@ contains end subroutine psb_d_set_multivect_default function psb_d_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: v class(psb_d_base_multivect_type), pointer :: res @@ -914,10 +1293,10 @@ contains function psb_d_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_d_base_multivect_type), pointer :: res - if (.not.allocated(psb_d_base_multivect_default)) then + if (.not.allocated(psb_d_base_multivect_default)) then allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default) end if @@ -927,14 +1306,14 @@ contains subroutine d_vect_clone(x,y,info) - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x class(psb_d_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine d_vect_clone @@ -947,7 +1326,7 @@ contains class(psb_d_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) @@ -965,7 +1344,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) @@ -1025,7 +1404,7 @@ contains end function size_const function d_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1033,7 +1412,7 @@ contains end function d_vect_get_nrows function d_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1041,7 +1420,7 @@ contains end function d_vect_get_ncols function d_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1049,7 +1428,7 @@ contains end function d_vect_sizeof function d_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_d_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1058,18 +1437,18 @@ contains subroutine d_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(out) :: x class(psb_d_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_d_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1079,12 +1458,12 @@ contains subroutine d_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1094,7 +1473,7 @@ contains subroutine d_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1104,7 +1483,7 @@ contains subroutine d_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1115,7 +1494,7 @@ contains end subroutine d_vect_asb subroutine d_vect_sync(x) - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1183,12 +1562,12 @@ contains subroutine d_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1197,7 +1576,7 @@ contains subroutine d_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_d_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1207,7 +1586,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1223,12 +1602,12 @@ contains class(psb_d_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_d_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1238,7 +1617,7 @@ contains !!$ function d_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res @@ -1250,28 +1629,28 @@ contains !!$ end function d_vect_dot_v !!$ !!$ function d_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ real(psb_dpk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res -!!$ +!!$ !!$ res = dzero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function d_vect_dot_a -!!$ +!!$ !!$ subroutine d_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ real(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1281,25 +1660,25 @@ contains !!$ !!$ subroutine d_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ real(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine d_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine d_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1310,7 +1689,7 @@ contains !!$ !!$ subroutine d_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1320,13 +1699,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine d_vect_mlt_a !!$ !!$ !!$ subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: y(:) !!$ real(psb_dpk_), intent(in) :: x(:) @@ -1334,20 +1713,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine d_vect_mlt_a_2 !!$ !!$ subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ class(psb_d_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1361,12 +1740,12 @@ contains !!$ !!$ subroutine d_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: x(:) !!$ class(psb_d_multivect_type), intent(inout) :: y !!$ class(psb_d_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1377,16 +1756,16 @@ contains !!$ !!$ subroutine d_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_dpk_), intent(in) :: alpha,beta !!$ real(psb_dpk_), intent(in) :: y(:) !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ class(psb_d_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1394,36 +1773,36 @@ contains !!$ !!$ subroutine d_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ real(psb_dpk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine d_vect_scal !!$ !!$ !!$ function d_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = dzero !!$ end if !!$ !!$ end function d_vect_nrm2 -!!$ +!!$ !!$ function d_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = dzero @@ -1432,12 +1811,12 @@ contains !!$ end function d_vect_amax !!$ !!$ function d_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_d_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = dzero diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index c18909312..851d7896d 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_i_base_vect_mod ! ! This module contains the definition of the psb_i_base_vect type which ! is a container for dense vectors. -! This is encapsulated instead of being just a simple array to allow for +! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran ! side. It is also meant to be encapsulated in an outer type, to allow @@ -43,15 +43,15 @@ ! ! module psb_i_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod !> \namespace psb_base_mod \class psb_i_base_vect_type - !! The psb_i_base_vect_type + !! The psb_i_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow @@ -59,9 +59,9 @@ module psb_i_base_vect_mod !! sparse matrix types. !! type psb_i_base_vect_type - !> Values. + !> Values. integer(psb_ipk_), allocatable :: v(:) - integer(psb_ipk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -76,7 +76,7 @@ module psb_i_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => i_base_ins_a procedure, pass(x) :: ins_v => i_base_ins_v @@ -91,7 +91,7 @@ module psb_i_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => i_base_sync procedure, pass(x) :: is_host => i_base_is_host @@ -128,7 +128,7 @@ module psb_i_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => i_base_gthab procedure, pass(x) :: gthzv => i_base_gthzv @@ -142,6 +142,10 @@ module psb_i_base_vect_mod + + + + end type psb_i_base_vect_type public :: psb_i_base_vect @@ -151,11 +155,11 @@ module psb_i_base_vect_mod end interface psb_i_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -168,11 +172,11 @@ contains this%v = x call this%asb(size(x,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -182,7 +186,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -194,20 +198,20 @@ contains !! subroutine i_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: this(:) class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine i_base_bld_x - + ! ! Create with size, but no initialization ! @@ -215,11 +219,11 @@ contains !> Function bld_mn: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine i_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -228,15 +232,15 @@ contains call x%asb(n,info) end subroutine i_base_bld_mn - + !> Function bld_en: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine i_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -245,24 +249,24 @@ contains call x%asb(n,info) end subroutine i_base_bld_en - + !> Function base_all: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine i_base_all(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_base_vect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(n,x%v,info) - + end subroutine i_base_all !> Function base_mold: @@ -274,11 +278,11 @@ contains subroutine i_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x class(psb_i_base_vect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_i_base_vect_type :: y, stat=info) end subroutine i_base_mold @@ -288,21 +292,21 @@ contains ! !> Function base_ins: !! \memberof psb_i_base_vect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -312,7 +316,7 @@ contains ! subroutine i_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -322,21 +326,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -344,7 +348,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -362,7 +366,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -371,7 +375,7 @@ contains subroutine i_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -381,14 +385,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() call x%ins(n,irl%v,val%v,dupl,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -404,14 +408,14 @@ contains ! subroutine i_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=izero call x%set_host() end subroutine i_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -420,20 +424,20 @@ contains !> Function base_asb: !! \memberof psb_i_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine i_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -450,20 +454,20 @@ contains !> Function base_asb: !! \memberof psb_i_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine i_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -476,39 +480,39 @@ contains !> Function base_free: !! \memberof psb_i_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine i_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if (info == 0) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine i_base_free - + ! !> Function base_free_buffer: !! \memberof psb_i_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine i_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -523,17 +527,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine i_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -543,13 +547,13 @@ contains !> Function base_free_comid: !! \memberof psb_i_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine i_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -561,77 +565,77 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_i_base_vect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine i_base_sync(x) - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x - + end subroutine i_base_sync ! !> Function base_set_host: !! \memberof psb_i_base_vect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine i_base_set_host(x) - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x - + end subroutine i_base_set_host ! !> Function base_set_dev: !! \memberof psb_i_base_vect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine i_base_set_dev(x) - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x - + end subroutine i_base_set_dev ! !> Function base_set_sync: !! \memberof psb_i_base_vect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine i_base_set_sync(x) - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x - + end subroutine i_base_set_sync ! !> Function base_is_dev: !! \memberof psb_i_base_vect_type !! \brief Is vector on external device . - !! + !! ! function i_base_is_dev(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x logical :: res - + res = .false. end function i_base_is_dev - + ! !> Function base_is_host !! \memberof psb_i_base_vect_type !! \brief Is vector on standard memory . - !! + !! ! function i_base_is_host(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x logical :: res @@ -642,10 +646,10 @@ contains !> Function base_is_sync !! \memberof psb_i_base_vect_type !! \brief Is vector on sync . - !! + !! ! function i_base_is_sync(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x logical :: res @@ -654,16 +658,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_i_base_vect_type !! \brief Number of entries - !! + !! ! function i_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -676,13 +680,13 @@ contains !> Function base_get_sizeof !! \memberof psb_i_base_vect_type !! \brief Size in bytes - !! + !! ! function i_base_sizeof(x) result(res) - implicit none + implicit none class(psb_i_base_vect_type), intent(in) :: x integer(psb_epk_) :: res - + ! Force 8-byte integers. res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() @@ -692,14 +696,14 @@ contains !> Function base_get_fmt !! \memberof psb_i_base_vect_type !! \brief Format - !! + !! ! function i_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function i_base_get_fmt - + ! ! @@ -708,7 +712,7 @@ contains !! \memberof psb_i_base_vect_type !! \brief Extract a copy of the contents !! - ! + ! function i_base_get_vect(x,n) result(res) class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), allocatable :: res(:) @@ -716,21 +720,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + if (.not.allocated(x%v)) return if (.not.x%is_host()) call x%sync() isz = x%get_nrows() if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function i_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -739,18 +743,18 @@ contains !! \param val The value to set !! subroutine i_base_set_scal(x,val,first,last) - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_ first_=1 last_=size(x%v) if (present(first)) first_ = max(1,first) if (present(last)) last_ = min(last,last_) - + if (x%is_dev()) call x%sync() x%v(first_:last_) = val call x%set_host() @@ -762,14 +766,14 @@ contains !> Function base_set_vect !! \memberof psb_i_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine i_base_set_vect(x,val,first,last) - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_, nr first_ = 1 @@ -777,7 +781,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -788,8 +792,8 @@ contains end subroutine i_base_set_vect - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -804,18 +808,18 @@ contains !! \param beta subroutine i_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: alpha, beta, y(:) class(psb_i_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,alpha,x%v,beta,y) end subroutine i_base_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_i_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -824,28 +828,28 @@ contains !! \param idx(:) indices subroutine i_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: y(:) class(psb_i_base_vect_type) :: x - + if (idx%is_dev()) call idx%sync() call x%gth(n,idx%v(i:),y) end subroutine i_base_gthzv_x ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine i_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_i_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -858,22 +862,22 @@ contains !> Function base_device_wait: !! \memberof psb_i_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine i_base_device_wait() - implicit none - + implicit none + end subroutine i_base_device_wait function i_base_use_buffer() result(res) logical :: res - + res = .true. end function i_base_use_buffer subroutine i_base_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -883,7 +887,7 @@ contains subroutine i_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -894,7 +898,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_i_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -903,20 +907,20 @@ contains !! \param idx(:) indices subroutine i_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: y(:) class(psb_i_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,x%v,y) end subroutine i_base_gthzv ! - ! Scatter: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_i_base_vect_type @@ -925,14 +929,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine i_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:) class(psb_i_base_vect_type) :: y - + if (y%is_dev()) call y%sync() call psi_sct(n,idx,x,beta,y%v) call y%set_host() @@ -941,12 +945,12 @@ contains subroutine i_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: beta, x(:) class(psb_i_base_vect_type) :: y - + if (idx%is_dev()) call idx%sync() call y%sct(n,idx%v(i:),x,beta) call y%set_host() @@ -955,14 +959,14 @@ contains subroutine i_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: beta class(psb_i_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -973,6 +977,7 @@ contains end subroutine i_base_sctb_buf + end module psb_i_base_vect_mod @@ -987,22 +992,22 @@ module psb_i_base_multivect_mod use psb_i_base_vect_mod !> \namespace psb_base_mod \class psb_i_base_vect_type - !! The psb_i_base_vect_type + !! The psb_i_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private + private public :: psb_i_base_multivect, psb_i_base_multivect_type type psb_i_base_multivect_type - !> Values. + !> Values. integer(psb_ipk_), allocatable :: v(:,:) - integer(psb_ipk_), allocatable :: combuf(:) + integer(psb_ipk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1016,7 +1021,7 @@ module psb_i_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => i_base_mlv_ins procedure, pass(x) :: zero => i_base_mlv_zero @@ -1027,7 +1032,7 @@ module psb_i_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => i_base_mlv_sync procedure, pass(x) :: is_host => i_base_mlv_is_host @@ -1067,7 +1072,7 @@ module psb_i_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => i_base_mlv_gthab procedure, pass(x) :: gthzv => i_base_mlv_gthzv @@ -1089,7 +1094,7 @@ module psb_i_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1108,7 +1113,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1135,7 +1140,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1150,7 +1155,7 @@ contains !> Function bld_n: !! \memberof psb_i_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine i_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1167,13 +1172,13 @@ contains !! \memberof psb_i_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine i_base_mlv_all(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1191,7 +1196,7 @@ contains subroutine i_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x class(psb_i_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info @@ -1205,21 +1210,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_i_base_multivect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -1229,7 +1234,7 @@ contains ! subroutine i_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1239,21 +1244,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -1261,7 +1266,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1278,7 +1283,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1293,7 +1298,7 @@ contains ! subroutine i_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=izero @@ -1309,7 +1314,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_i_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1318,7 +1323,7 @@ contains subroutine i_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1335,20 +1340,20 @@ contains !> Function base_mlv_free: !! \memberof psb_i_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine i_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine i_base_mlv_free @@ -1358,15 +1363,15 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_mlv_sync: !! \memberof psb_i_base_multivect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine i_base_mlv_sync(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_sync @@ -1375,10 +1380,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_i_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine i_base_mlv_set_host(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_set_host @@ -1387,10 +1392,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_i_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine i_base_mlv_set_dev(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_set_dev @@ -1399,10 +1404,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_i_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine i_base_mlv_set_sync(x) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x end subroutine i_base_mlv_set_sync @@ -1411,10 +1416,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_i_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function i_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x logical :: res @@ -1425,10 +1430,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_i_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function i_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x logical :: res @@ -1439,10 +1444,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_i_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function i_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x logical :: res @@ -1451,16 +1456,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_i_base_multivect_type !! \brief Number of entries - !! + !! ! function i_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1470,7 +1475,7 @@ contains end function i_base_mlv_get_nrows function i_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1483,10 +1488,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_i_base_multivect_type !! \brief Size in bytesa - !! + !! ! function i_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1499,10 +1504,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_i_base_multivect_type !! \brief Format - !! + !! ! function i_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function i_base_mlv_get_fmt @@ -1515,18 +1520,18 @@ contains !! \memberof psb_i_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function i_base_mlv_get_vect(x) result(res) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), allocatable :: res(:,:) integer(psb_ipk_) :: info,m,n m = x%get_nrows() n = x%get_ncols() - if (.not.allocated(x%v)) return + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -1534,7 +1539,7 @@ contains end function i_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -1543,7 +1548,7 @@ contains !! \param val The value to set !! subroutine i_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val @@ -1556,16 +1561,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_i_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine i_base_mlv_set_vect(x,val) - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_) :: nr, nc integer(psb_ipk_) :: info - if (allocated(x%v)) then + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -1578,15 +1583,15 @@ contains function i_base_mlv_use_buffer() result(res) - implicit none + implicit none logical :: res - + res = .true. end function i_base_mlv_use_buffer subroutine i_base_mlv_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1598,7 +1603,7 @@ contains subroutine i_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1609,12 +1614,12 @@ contains subroutine i_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -1622,7 +1627,7 @@ contains subroutine i_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1632,7 +1637,7 @@ contains subroutine i_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_i_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1655,7 +1660,7 @@ contains !! \param beta subroutine i_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: alpha, beta, y(:) class(psb_i_base_multivect_type) :: x @@ -1671,7 +1676,7 @@ contains end subroutine i_base_mlv_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_i_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1680,7 +1685,7 @@ contains !! \param idx(:) indices subroutine i_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: y(:) @@ -1693,7 +1698,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_i_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1702,7 +1707,7 @@ contains !! \param idx(:) indices subroutine i_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: y(:) class(psb_i_base_multivect_type) :: x @@ -1719,7 +1724,7 @@ contains end subroutine i_base_mlv_gthzv ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_i_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1728,7 +1733,7 @@ contains !! \param idx(:) indices subroutine i_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: y(:,:) class(psb_i_base_multivect_type) :: x @@ -1745,17 +1750,17 @@ contains end subroutine i_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine i_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_i_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1767,9 +1772,9 @@ contains end subroutine i_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_i_base_multivect_type @@ -1778,10 +1783,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine i_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:) class(psb_i_base_multivect_type) :: y @@ -1796,7 +1801,7 @@ contains subroutine i_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_ipk_) :: beta, x(:,:) class(psb_i_base_multivect_type) :: y @@ -1811,7 +1816,7 @@ contains subroutine i_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer( psb_ipk_) :: beta, x(:) @@ -1823,14 +1828,14 @@ contains subroutine i_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n class(psb_i_base_vect_type) :: idx integer(psb_ipk_) :: beta class(psb_i_base_multivect_type) :: y integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1839,19 +1844,18 @@ contains nc = y%get_ncols() call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) call y%set_host() - + end subroutine i_base_mlv_sctb_buf ! !> Function base_device_wait: !! \memberof psb_i_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine i_base_mlv_device_wait() - implicit none - + implicit none + end subroutine i_base_mlv_device_wait end module psb_i_base_multivect_mod - diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 2b3ad2528..6fe133256 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,22 +27,22 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_i_vect_mod ! ! This module contains the definition of the psb_i_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_i_vect_mod use psb_i_base_vect_mod type psb_i_vect_type - class(psb_i_base_vect_type), allocatable :: v + class(psb_i_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => i_vect_get_nrows procedure, pass(x) :: sizeof => i_vect_sizeof @@ -79,6 +79,8 @@ module psb_i_vect_mod procedure, pass(x) :: set_dev => i_vect_set_dev procedure, pass(x) :: set_sync => i_vect_set_sync + + end type psb_i_vect_type public :: psb_i_vect @@ -98,7 +100,6 @@ module psb_i_vect_mod & i_vect_set_dev, i_vect_set_sync - class(psb_i_base_vect_type), allocatable, target,& & save, private :: psb_i_base_vect_default @@ -114,11 +115,11 @@ module psb_i_vect_mod contains - subroutine psb_i_set_vect_default(v) - implicit none + subroutine psb_i_set_vect_default(v) + implicit none class(psb_i_base_vect_type), intent(in) :: v - if (allocated(psb_i_base_vect_default)) then + if (allocated(psb_i_base_vect_default)) then deallocate(psb_i_base_vect_default) end if allocate(psb_i_base_vect_default, mold=v) @@ -126,7 +127,7 @@ contains end subroutine psb_i_set_vect_default function psb_i_get_vect_default(v) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: v class(psb_i_base_vect_type), pointer :: res @@ -144,10 +145,10 @@ contains end subroutine psb_i_clear_vect_default function psb_i_get_base_vect_default() result(res) - implicit none + implicit none class(psb_i_base_vect_type), pointer :: res - if (.not.allocated(psb_i_base_vect_default)) then + if (.not.allocated(psb_i_base_vect_default)) then allocate(psb_i_base_vect_type :: psb_i_base_vect_default) end if @@ -156,14 +157,14 @@ contains end function psb_i_get_base_vect_default subroutine i_vect_clone(x,y,info) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine i_vect_clone @@ -178,7 +179,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) @@ -200,7 +201,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) @@ -220,7 +221,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) @@ -283,7 +284,7 @@ contains end function size_const function i_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -291,7 +292,7 @@ contains end function i_vect_get_nrows function i_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -299,7 +300,7 @@ contains end function i_vect_sizeof function i_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_i_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -308,7 +309,7 @@ contains subroutine i_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold @@ -317,12 +318,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_i_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -332,12 +333,12 @@ contains subroutine i_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -347,7 +348,7 @@ contains subroutine i_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -357,7 +358,7 @@ contains subroutine i_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -403,12 +404,12 @@ contains subroutine i_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -417,7 +418,7 @@ contains subroutine i_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -427,7 +428,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -438,7 +439,7 @@ contains subroutine i_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -448,7 +449,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -466,12 +467,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_i_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -482,7 +483,7 @@ contains subroutine i_vect_sync(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -491,7 +492,7 @@ contains end subroutine i_vect_sync subroutine i_vect_set_sync(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -500,7 +501,7 @@ contains end subroutine i_vect_set_sync subroutine i_vect_set_host(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -509,7 +510,7 @@ contains end subroutine i_vect_set_host subroutine i_vect_set_dev(x) - implicit none + implicit none class(psb_i_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -518,7 +519,7 @@ contains end subroutine i_vect_set_dev function i_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x @@ -529,7 +530,7 @@ contains end function i_vect_is_sync function i_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x @@ -540,17 +541,19 @@ contains end function i_vect_is_host function i_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_i_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() end function i_vect_is_dev + + end module psb_i_vect_mod @@ -565,7 +568,7 @@ module psb_i_multivect_mod !private type psb_i_multivect_type - class(psb_i_base_multivect_type), allocatable :: v + class(psb_i_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => i_vect_get_nrows procedure, pass(x) :: get_ncols => i_vect_get_ncols @@ -621,11 +624,11 @@ module psb_i_multivect_mod contains - subroutine psb_i_set_multivect_default(v) - implicit none + subroutine psb_i_set_multivect_default(v) + implicit none class(psb_i_base_multivect_type), intent(in) :: v - if (allocated(psb_i_base_multivect_default)) then + if (allocated(psb_i_base_multivect_default)) then deallocate(psb_i_base_multivect_default) end if allocate(psb_i_base_multivect_default, mold=v) @@ -633,7 +636,7 @@ contains end subroutine psb_i_set_multivect_default function psb_i_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: v class(psb_i_base_multivect_type), pointer :: res @@ -643,10 +646,10 @@ contains function psb_i_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_i_base_multivect_type), pointer :: res - if (.not.allocated(psb_i_base_multivect_default)) then + if (.not.allocated(psb_i_base_multivect_default)) then allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default) end if @@ -656,14 +659,14 @@ contains subroutine i_vect_clone(x,y,info) - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x class(psb_i_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine i_vect_clone @@ -676,7 +679,7 @@ contains class(psb_i_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) @@ -694,7 +697,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) @@ -754,7 +757,7 @@ contains end function size_const function i_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -762,7 +765,7 @@ contains end function i_vect_get_nrows function i_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -770,7 +773,7 @@ contains end function i_vect_get_ncols function i_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -778,7 +781,7 @@ contains end function i_vect_sizeof function i_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_i_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -787,18 +790,18 @@ contains subroutine i_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(out) :: x class(psb_i_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_i_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -808,12 +811,12 @@ contains subroutine i_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -823,7 +826,7 @@ contains subroutine i_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -833,7 +836,7 @@ contains subroutine i_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -844,7 +847,7 @@ contains end subroutine i_vect_asb subroutine i_vect_sync(x) - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -912,12 +915,12 @@ contains subroutine i_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -926,7 +929,7 @@ contains subroutine i_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_i_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -936,7 +939,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -952,12 +955,12 @@ contains class(psb_i_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_i_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) diff --git a/base/modules/serial/psb_l_base_vect_mod.f90 b/base/modules/serial/psb_l_base_vect_mod.f90 index ab7b49f1f..58eda6308 100644 --- a/base/modules/serial/psb_l_base_vect_mod.f90 +++ b/base/modules/serial/psb_l_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_l_base_vect_mod ! ! This module contains the definition of the psb_l_base_vect type which ! is a container for dense vectors. -! This is encapsulated instead of being just a simple array to allow for +! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran ! side. It is also meant to be encapsulated in an outer type, to allow @@ -43,16 +43,16 @@ ! ! module psb_l_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod !> \namespace psb_base_mod \class psb_l_base_vect_type - !! The psb_l_base_vect_type + !! The psb_l_base_vect_type !! defines a middle level integer(psb_lpk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow @@ -60,9 +60,9 @@ module psb_l_base_vect_mod !! sparse matrix types. !! type psb_l_base_vect_type - !> Values. + !> Values. integer(psb_lpk_), allocatable :: v(:) - integer(psb_lpk_), allocatable :: combuf(:) + integer(psb_lpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -77,7 +77,7 @@ module psb_l_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => l_base_ins_a procedure, pass(x) :: ins_v => l_base_ins_v @@ -92,7 +92,7 @@ module psb_l_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => l_base_sync procedure, pass(x) :: is_host => l_base_is_host @@ -129,7 +129,7 @@ module psb_l_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => l_base_gthab procedure, pass(x) :: gthzv => l_base_gthzv @@ -143,6 +143,10 @@ module psb_l_base_vect_mod + + + + end type psb_l_base_vect_type public :: psb_l_base_vect @@ -152,11 +156,11 @@ module psb_l_base_vect_mod end interface psb_l_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -169,11 +173,11 @@ contains this%v = x call this%asb(size(x,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -183,7 +187,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -195,20 +199,20 @@ contains !! subroutine l_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: this(:) class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine l_base_bld_x - + ! ! Create with size, but no initialization ! @@ -216,11 +220,11 @@ contains !> Function bld_mn: !! \memberof psb_l_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine l_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -229,15 +233,15 @@ contains call x%asb(n,info) end subroutine l_base_bld_mn - + !> Function bld_en: !! \memberof psb_l_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine l_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -246,24 +250,24 @@ contains call x%asb(n,info) end subroutine l_base_bld_en - + !> Function base_all: !! \memberof psb_l_base_vect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine l_base_all(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_base_vect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(n,x%v,info) - + end subroutine l_base_all !> Function base_mold: @@ -275,11 +279,11 @@ contains subroutine l_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x class(psb_l_base_vect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_l_base_vect_type :: y, stat=info) end subroutine l_base_mold @@ -289,21 +293,21 @@ contains ! !> Function base_ins: !! \memberof psb_l_base_vect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -313,7 +317,7 @@ contains ! subroutine l_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -323,21 +327,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -345,7 +349,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -363,7 +367,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -372,7 +376,7 @@ contains subroutine l_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -382,14 +386,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() call x%ins(n,irl%v,val%v,dupl,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -405,14 +409,14 @@ contains ! subroutine l_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=lzero call x%set_host() end subroutine l_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -421,20 +425,20 @@ contains !> Function base_asb: !! \memberof psb_l_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine l_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -451,20 +455,20 @@ contains !> Function base_asb: !! \memberof psb_l_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine l_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -477,39 +481,39 @@ contains !> Function base_free: !! \memberof psb_l_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine l_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if (info == 0) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine l_base_free - + ! !> Function base_free_buffer: !! \memberof psb_l_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine l_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -524,17 +528,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine l_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -544,13 +548,13 @@ contains !> Function base_free_comid: !! \memberof psb_l_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine l_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -562,77 +566,77 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_l_base_vect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine l_base_sync(x) - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x - + end subroutine l_base_sync ! !> Function base_set_host: !! \memberof psb_l_base_vect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine l_base_set_host(x) - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x - + end subroutine l_base_set_host ! !> Function base_set_dev: !! \memberof psb_l_base_vect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine l_base_set_dev(x) - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x - + end subroutine l_base_set_dev ! !> Function base_set_sync: !! \memberof psb_l_base_vect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine l_base_set_sync(x) - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x - + end subroutine l_base_set_sync ! !> Function base_is_dev: !! \memberof psb_l_base_vect_type !! \brief Is vector on external device . - !! + !! ! function l_base_is_dev(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x logical :: res - + res = .false. end function l_base_is_dev - + ! !> Function base_is_host !! \memberof psb_l_base_vect_type !! \brief Is vector on standard memory . - !! + !! ! function l_base_is_host(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x logical :: res @@ -643,10 +647,10 @@ contains !> Function base_is_sync !! \memberof psb_l_base_vect_type !! \brief Is vector on sync . - !! + !! ! function l_base_is_sync(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x logical :: res @@ -655,16 +659,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_l_base_vect_type !! \brief Number of entries - !! + !! ! function l_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -677,13 +681,13 @@ contains !> Function base_get_sizeof !! \memberof psb_l_base_vect_type !! \brief Size in bytes - !! + !! ! function l_base_sizeof(x) result(res) - implicit none + implicit none class(psb_l_base_vect_type), intent(in) :: x integer(psb_epk_) :: res - + ! Force 8-byte integers. res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() @@ -693,14 +697,14 @@ contains !> Function base_get_fmt !! \memberof psb_l_base_vect_type !! \brief Format - !! + !! ! function l_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function l_base_get_fmt - + ! ! @@ -709,7 +713,7 @@ contains !! \memberof psb_l_base_vect_type !! \brief Extract a copy of the contents !! - ! + ! function l_base_get_vect(x,n) result(res) class(psb_l_base_vect_type), intent(inout) :: x integer(psb_lpk_), allocatable :: res(:) @@ -717,21 +721,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + if (.not.allocated(x%v)) return if (.not.x%is_host()) call x%sync() isz = x%get_nrows() if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function l_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -740,18 +744,18 @@ contains !! \param val The value to set !! subroutine l_base_set_scal(x,val,first,last) - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_lpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_ first_=1 last_=size(x%v) if (present(first)) first_ = max(1,first) if (present(last)) last_ = min(last,last_) - + if (x%is_dev()) call x%sync() x%v(first_:last_) = val call x%set_host() @@ -763,14 +767,14 @@ contains !> Function base_set_vect !! \memberof psb_l_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine l_base_set_vect(x,val,first,last) - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_lpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_, nr first_ = 1 @@ -778,7 +782,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -789,8 +793,8 @@ contains end subroutine l_base_set_vect - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -805,18 +809,18 @@ contains !! \param beta subroutine l_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: alpha, beta, y(:) class(psb_l_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,alpha,x%v,beta,y) end subroutine l_base_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_l_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -825,28 +829,28 @@ contains !! \param idx(:) indices subroutine l_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: y(:) class(psb_l_base_vect_type) :: x - + if (idx%is_dev()) call idx%sync() call x%gth(n,idx%v(i:),y) end subroutine l_base_gthzv_x ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine l_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_l_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -859,22 +863,22 @@ contains !> Function base_device_wait: !! \memberof psb_l_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine l_base_device_wait() - implicit none - + implicit none + end subroutine l_base_device_wait function l_base_use_buffer() result(res) logical :: res - + res = .true. end function l_base_use_buffer subroutine l_base_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -884,7 +888,7 @@ contains subroutine l_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -895,7 +899,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_l_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -904,20 +908,20 @@ contains !! \param idx(:) indices subroutine l_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: y(:) class(psb_l_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,x%v,y) end subroutine l_base_gthzv ! - ! Scatter: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_l_base_vect_type @@ -926,14 +930,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine l_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: beta, x(:) class(psb_l_base_vect_type) :: y - + if (y%is_dev()) call y%sync() call psi_sct(n,idx,x,beta,y%v) call y%set_host() @@ -942,12 +946,12 @@ contains subroutine l_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: beta, x(:) class(psb_l_base_vect_type) :: y - + if (idx%is_dev()) call idx%sync() call y%sct(n,idx%v(i:),x,beta) call y%set_host() @@ -956,14 +960,14 @@ contains subroutine l_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: beta class(psb_l_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -974,6 +978,7 @@ contains end subroutine l_base_sctb_buf + end module psb_l_base_vect_mod @@ -988,22 +993,22 @@ module psb_l_base_multivect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_l_base_vect_type - !! The psb_l_base_vect_type + !! The psb_l_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private + private public :: psb_l_base_multivect, psb_l_base_multivect_type type psb_l_base_multivect_type - !> Values. + !> Values. integer(psb_lpk_), allocatable :: v(:,:) - integer(psb_lpk_), allocatable :: combuf(:) + integer(psb_lpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1017,7 +1022,7 @@ module psb_l_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => l_base_mlv_ins procedure, pass(x) :: zero => l_base_mlv_zero @@ -1028,7 +1033,7 @@ module psb_l_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => l_base_mlv_sync procedure, pass(x) :: is_host => l_base_mlv_is_host @@ -1068,7 +1073,7 @@ module psb_l_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => l_base_mlv_gthab procedure, pass(x) :: gthzv => l_base_mlv_gthzv @@ -1090,7 +1095,7 @@ module psb_l_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1109,7 +1114,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1136,7 +1141,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1151,7 +1156,7 @@ contains !> Function bld_n: !! \memberof psb_l_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine l_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1168,13 +1173,13 @@ contains !! \memberof psb_l_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine l_base_mlv_all(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1192,7 +1197,7 @@ contains subroutine l_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x class(psb_l_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info @@ -1206,21 +1211,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_l_base_multivect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -1230,7 +1235,7 @@ contains ! subroutine l_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1240,21 +1245,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -1262,7 +1267,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1279,7 +1284,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1294,7 +1299,7 @@ contains ! subroutine l_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=lzero @@ -1310,7 +1315,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_l_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1319,7 +1324,7 @@ contains subroutine l_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1336,20 +1341,20 @@ contains !> Function base_mlv_free: !! \memberof psb_l_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine l_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine l_base_mlv_free @@ -1359,15 +1364,15 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_mlv_sync: !! \memberof psb_l_base_multivect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine l_base_mlv_sync(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_sync @@ -1376,10 +1381,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_l_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine l_base_mlv_set_host(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_set_host @@ -1388,10 +1393,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_l_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine l_base_mlv_set_dev(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_set_dev @@ -1400,10 +1405,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_l_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine l_base_mlv_set_sync(x) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x end subroutine l_base_mlv_set_sync @@ -1412,10 +1417,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_l_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function l_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x logical :: res @@ -1426,10 +1431,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_l_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function l_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x logical :: res @@ -1440,10 +1445,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_l_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function l_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x logical :: res @@ -1452,16 +1457,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_l_base_multivect_type !! \brief Number of entries - !! + !! ! function l_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1471,7 +1476,7 @@ contains end function l_base_mlv_get_nrows function l_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1484,10 +1489,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_l_base_multivect_type !! \brief Size in bytesa - !! + !! ! function l_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1500,10 +1505,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_l_base_multivect_type !! \brief Format - !! + !! ! function l_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function l_base_mlv_get_fmt @@ -1516,18 +1521,18 @@ contains !! \memberof psb_l_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function l_base_mlv_get_vect(x) result(res) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_lpk_), allocatable :: res(:,:) integer(psb_ipk_) :: info,m,n m = x%get_nrows() n = x%get_ncols() - if (.not.allocated(x%v)) return + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -1535,7 +1540,7 @@ contains end function l_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -1544,7 +1549,7 @@ contains !! \param val The value to set !! subroutine l_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_lpk_), intent(in) :: val @@ -1557,16 +1562,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_l_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine l_base_mlv_set_vect(x,val) - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_lpk_), intent(in) :: val(:,:) integer(psb_ipk_) :: nr, nc integer(psb_ipk_) :: info - if (allocated(x%v)) then + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -1579,15 +1584,15 @@ contains function l_base_mlv_use_buffer() result(res) - implicit none + implicit none logical :: res - + res = .true. end function l_base_mlv_use_buffer subroutine l_base_mlv_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1599,7 +1604,7 @@ contains subroutine l_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1610,12 +1615,12 @@ contains subroutine l_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -1623,7 +1628,7 @@ contains subroutine l_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1633,7 +1638,7 @@ contains subroutine l_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_l_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1656,7 +1661,7 @@ contains !! \param beta subroutine l_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: alpha, beta, y(:) class(psb_l_base_multivect_type) :: x @@ -1672,7 +1677,7 @@ contains end subroutine l_base_mlv_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_l_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1681,7 +1686,7 @@ contains !! \param idx(:) indices subroutine l_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: y(:) @@ -1694,7 +1699,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_l_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1703,7 +1708,7 @@ contains !! \param idx(:) indices subroutine l_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: y(:) class(psb_l_base_multivect_type) :: x @@ -1720,7 +1725,7 @@ contains end subroutine l_base_mlv_gthzv ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_l_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1729,7 +1734,7 @@ contains !! \param idx(:) indices subroutine l_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: y(:,:) class(psb_l_base_multivect_type) :: x @@ -1746,17 +1751,17 @@ contains end subroutine l_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_l_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1768,9 +1773,9 @@ contains end subroutine l_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_l_base_multivect_type @@ -1779,10 +1784,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine l_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: beta, x(:) class(psb_l_base_multivect_type) :: y @@ -1797,7 +1802,7 @@ contains subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) integer(psb_lpk_) :: beta, x(:,:) class(psb_l_base_multivect_type) :: y @@ -1812,7 +1817,7 @@ contains subroutine l_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx integer( psb_lpk_) :: beta, x(:) @@ -1824,14 +1829,14 @@ contains subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n class(psb_i_base_vect_type) :: idx integer(psb_lpk_) :: beta class(psb_l_base_multivect_type) :: y integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1840,19 +1845,18 @@ contains nc = y%get_ncols() call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) call y%set_host() - + end subroutine l_base_mlv_sctb_buf ! !> Function base_device_wait: !! \memberof psb_l_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine l_base_mlv_device_wait() - implicit none - + implicit none + end subroutine l_base_mlv_device_wait end module psb_l_base_multivect_mod - diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 index baeb64134..c8fe90e60 100644 --- a/base/modules/serial/psb_l_vect_mod.F90 +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_l_vect_mod ! ! This module contains the definition of the psb_l_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_l_vect_mod @@ -43,7 +43,7 @@ module psb_l_vect_mod use psb_i_vect_mod type psb_l_vect_type - class(psb_l_base_vect_type), allocatable :: v + class(psb_l_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => l_vect_get_nrows procedure, pass(x) :: sizeof => l_vect_sizeof @@ -80,6 +80,8 @@ module psb_l_vect_mod procedure, pass(x) :: set_dev => l_vect_set_dev procedure, pass(x) :: set_sync => l_vect_set_sync + + end type psb_l_vect_type public :: psb_l_vect @@ -99,7 +101,6 @@ module psb_l_vect_mod & l_vect_set_dev, l_vect_set_sync - class(psb_l_base_vect_type), allocatable, target,& & save, private :: psb_l_base_vect_default @@ -115,11 +116,11 @@ module psb_l_vect_mod contains - subroutine psb_l_set_vect_default(v) - implicit none + subroutine psb_l_set_vect_default(v) + implicit none class(psb_l_base_vect_type), intent(in) :: v - if (allocated(psb_l_base_vect_default)) then + if (allocated(psb_l_base_vect_default)) then deallocate(psb_l_base_vect_default) end if allocate(psb_l_base_vect_default, mold=v) @@ -127,7 +128,7 @@ contains end subroutine psb_l_set_vect_default function psb_l_get_vect_default(v) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: v class(psb_l_base_vect_type), pointer :: res @@ -145,10 +146,10 @@ contains end subroutine psb_l_clear_vect_default function psb_l_get_base_vect_default() result(res) - implicit none + implicit none class(psb_l_base_vect_type), pointer :: res - if (.not.allocated(psb_l_base_vect_default)) then + if (.not.allocated(psb_l_base_vect_default)) then allocate(psb_l_base_vect_type :: psb_l_base_vect_default) end if @@ -157,14 +158,14 @@ contains end function psb_l_get_base_vect_default subroutine l_vect_clone(x,y,info) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine l_vect_clone @@ -179,7 +180,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) @@ -201,7 +202,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) @@ -221,7 +222,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) @@ -284,7 +285,7 @@ contains end function size_const function l_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -292,7 +293,7 @@ contains end function l_vect_get_nrows function l_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -300,7 +301,7 @@ contains end function l_vect_sizeof function l_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_l_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -309,7 +310,7 @@ contains subroutine l_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x class(psb_l_base_vect_type), intent(in), optional :: mold @@ -318,12 +319,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_l_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -333,12 +334,12 @@ contains subroutine l_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -348,7 +349,7 @@ contains subroutine l_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -358,7 +359,7 @@ contains subroutine l_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -404,12 +405,12 @@ contains subroutine l_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -418,7 +419,7 @@ contains subroutine l_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -428,7 +429,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -439,7 +440,7 @@ contains subroutine l_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -449,7 +450,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -467,12 +468,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_l_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -483,7 +484,7 @@ contains subroutine l_vect_sync(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -492,7 +493,7 @@ contains end subroutine l_vect_sync subroutine l_vect_set_sync(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -501,7 +502,7 @@ contains end subroutine l_vect_set_sync subroutine l_vect_set_host(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -510,7 +511,7 @@ contains end subroutine l_vect_set_host subroutine l_vect_set_dev(x) - implicit none + implicit none class(psb_l_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -519,7 +520,7 @@ contains end subroutine l_vect_set_dev function l_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_l_vect_type), intent(inout) :: x @@ -530,7 +531,7 @@ contains end function l_vect_is_sync function l_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_l_vect_type), intent(inout) :: x @@ -541,17 +542,19 @@ contains end function l_vect_is_host function l_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_l_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() end function l_vect_is_dev + + end module psb_l_vect_mod @@ -566,7 +569,7 @@ module psb_l_multivect_mod !private type psb_l_multivect_type - class(psb_l_base_multivect_type), allocatable :: v + class(psb_l_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => l_vect_get_nrows procedure, pass(x) :: get_ncols => l_vect_get_ncols @@ -622,11 +625,11 @@ module psb_l_multivect_mod contains - subroutine psb_l_set_multivect_default(v) - implicit none + subroutine psb_l_set_multivect_default(v) + implicit none class(psb_l_base_multivect_type), intent(in) :: v - if (allocated(psb_l_base_multivect_default)) then + if (allocated(psb_l_base_multivect_default)) then deallocate(psb_l_base_multivect_default) end if allocate(psb_l_base_multivect_default, mold=v) @@ -634,7 +637,7 @@ contains end subroutine psb_l_set_multivect_default function psb_l_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: v class(psb_l_base_multivect_type), pointer :: res @@ -644,10 +647,10 @@ contains function psb_l_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_l_base_multivect_type), pointer :: res - if (.not.allocated(psb_l_base_multivect_default)) then + if (.not.allocated(psb_l_base_multivect_default)) then allocate(psb_l_base_multivect_type :: psb_l_base_multivect_default) end if @@ -657,14 +660,14 @@ contains subroutine l_vect_clone(x,y,info) - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x class(psb_l_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine l_vect_clone @@ -677,7 +680,7 @@ contains class(psb_l_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) @@ -695,7 +698,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) @@ -755,7 +758,7 @@ contains end function size_const function l_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -763,7 +766,7 @@ contains end function l_vect_get_nrows function l_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -771,7 +774,7 @@ contains end function l_vect_get_ncols function l_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -779,7 +782,7 @@ contains end function l_vect_sizeof function l_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_l_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -788,18 +791,18 @@ contains subroutine l_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_multivect_type), intent(out) :: x class(psb_l_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_l_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -809,12 +812,12 @@ contains subroutine l_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -824,7 +827,7 @@ contains subroutine l_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -834,7 +837,7 @@ contains subroutine l_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -845,7 +848,7 @@ contains end subroutine l_vect_asb subroutine l_vect_sync(x) - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -913,12 +916,12 @@ contains subroutine l_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -927,7 +930,7 @@ contains subroutine l_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_l_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -937,7 +940,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -953,12 +956,12 @@ contains class(psb_l_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_l_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) diff --git a/base/modules/serial/psb_s_base_mat_mod.F90 b/base/modules/serial/psb_s_base_mat_mod.F90 index f665a0485..95bab09ee 100644 --- a/base/modules/serial/psb_s_base_mat_mod.F90 +++ b/base/modules/serial/psb_s_base_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,12 +27,12 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! module psb_s_base_mat_mod - + use psb_base_mat_mod use psb_s_base_vect_mod @@ -56,59 +56,59 @@ module psb_s_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_s_base_csput_a - procedure, pass(a) :: csput_v => psb_s_base_csput_v + procedure, pass(a) :: csput_v => psb_s_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_s_base_csgetrow procedure, pass(a) :: csgetblk => psb_s_base_csgetblk procedure, pass(a) :: get_diag => psb_s_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_s_base_tril procedure, pass(a) :: triu => psb_s_base_triu - procedure, pass(a) :: csclip => psb_s_base_csclip - procedure, pass(a) :: cp_to_coo => psb_s_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_s_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_s_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_s_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_s_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_s_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_s_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_s_base_mv_from_fmt - procedure, pass(a) :: mold => psb_s_base_mold + procedure, pass(a) :: csclip => psb_s_base_csclip + procedure, pass(a) :: cp_to_coo => psb_s_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_s_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_s_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_s_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_s_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_s_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_s_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_s_base_mv_from_fmt + procedure, pass(a) :: mold => psb_s_base_mold procedure, pass(a) :: clone => psb_s_base_clone procedure, pass(a) :: make_nonunit => psb_s_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_s_base_clean_zeros ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_s_base_cp_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_s_base_cp_from_lcoo - procedure, pass(a) :: cp_to_lfmt => psb_s_base_cp_to_lfmt - procedure, pass(a) :: cp_from_lfmt => psb_s_base_cp_from_lfmt - procedure, pass(a) :: mv_to_lcoo => psb_s_base_mv_to_lcoo - procedure, pass(a) :: mv_from_lcoo => psb_s_base_mv_from_lcoo - procedure, pass(a) :: mv_to_lfmt => psb_s_base_mv_to_lfmt - procedure, pass(a) :: mv_from_lfmt => psb_s_base_mv_from_lfmt + procedure, pass(a) :: cp_to_lcoo => psb_s_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_s_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_s_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_s_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_s_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_s_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_s_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_s_base_mv_from_lfmt + - ! - ! Transpose methods: defined here but not implemented. - ! + ! Transpose methods: defined here but not implemented. + ! procedure, pass(a) :: transp_1mat => psb_s_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_s_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_s_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_s_base_transc_2mat - + + ! + ! Computational methods: defined here but not implemented. ! - ! Computational methods: defined here but not implemented. - ! procedure, pass(a) :: vect_mv => psb_s_base_vect_mv procedure, pass(a) :: csmv => psb_s_base_csmv procedure, pass(a) :: csmm => psb_s_base_csmm generic, public :: spmm => csmm, csmv, vect_mv procedure, pass(a) :: in_vect_sv => psb_s_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_s_base_inner_cssv + procedure, pass(a) :: inner_cssv => psb_s_base_inner_cssv procedure, pass(a) :: inner_cssm => psb_s_base_inner_cssm generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv procedure, pass(a) :: vect_cssv => psb_s_base_vect_cssv @@ -125,15 +125,20 @@ module psb_s_base_mat_mod procedure, pass(a) :: arwsum => psb_s_base_arwsum procedure, pass(a) :: colsum => psb_s_base_colsum procedure, pass(a) :: aclsum => psb_s_base_aclsum + procedure, pass(a) :: scalpid => psb_s_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_s_base_spaxpby + procedure, pass(a) :: cmpval => psb_s_base_cmpval + procedure, pass(a) :: cmpmat => psb_s_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_s_base_sparse_mat - + private :: s_base_mat_sync, s_base_mat_is_host, s_base_mat_is_dev, & & s_base_mat_is_sync, s_base_mat_set_host, s_base_mat_set_dev,& & s_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_s_coo_sparse_mat !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat - !! + !! !! psb_s_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -147,15 +152,15 @@ module psb_s_base_mat_mod integer(psb_ipk_), allocatable :: ia(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_spk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => s_coo_get_size procedure, pass(a) :: get_nzeros => s_coo_get_nzeros procedure, nopass :: get_fmt => s_coo_get_fmt @@ -175,9 +180,9 @@ module psb_s_base_mat_mod ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_s_cp_coo_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_s_cp_coo_from_lcoo - + procedure, pass(a) :: cp_to_lcoo => psb_s_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_s_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_s_coo_csput_a procedure, pass(a) :: get_diag => psb_s_coo_get_diag procedure, pass(a) :: csgetrow => psb_s_coo_csgetrow @@ -203,18 +208,18 @@ module psb_s_base_mat_mod ! This is COO specific ! procedure, pass(a) :: set_nzeros => s_coo_set_nzeros - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => s_coo_transp_1mat procedure, pass(a) :: transc_1mat => s_coo_transc_1mat ! - ! Computational methods. - ! + ! Computational methods. + ! procedure, pass(a) :: csmm => psb_s_coo_csmm procedure, pass(a) :: csmv => psb_s_coo_csmv procedure, pass(a) :: inner_cssm => psb_s_coo_cssm @@ -228,14 +233,17 @@ module psb_s_base_mat_mod procedure, pass(a) :: arwsum => psb_s_coo_arwsum procedure, pass(a) :: colsum => psb_s_coo_colsum procedure, pass(a) :: aclsum => psb_s_coo_aclsum - + procedure, pass(a) :: scalpid => psb_s_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_s_coo_spaxpby + procedure, pass(a) :: cmpval => psb_s_coo_cmpval + procedure, pass(a) :: cmpmat => psb_s_coo_cmpmat end type psb_s_coo_sparse_mat - + private :: s_coo_get_nzeros, s_coo_set_nzeros, & & s_coo_get_fmt, s_coo_free, s_coo_sizeof, & & s_coo_transp_1mat, s_coo_transc_1mat - - + + !> \namespace psb_base_mod \class psb_ls_base_sparse_mat !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat !! The psb_ls_base_sparse_mat type, extending psb_base_sparse_mat, @@ -255,33 +263,33 @@ module psb_s_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_ls_base_csput_a - procedure, pass(a) :: csput_v => psb_ls_base_csput_v + procedure, pass(a) :: csput_v => psb_ls_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_ls_base_csgetrow procedure, pass(a) :: csgetblk => psb_ls_base_csgetblk procedure, pass(a) :: get_diag => psb_ls_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_ls_base_tril procedure, pass(a) :: triu => psb_ls_base_triu - procedure, pass(a) :: csclip => psb_ls_base_csclip - procedure, pass(a) :: cp_to_coo => psb_ls_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_ls_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_ls_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_ls_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_ls_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_ls_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_ls_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_ls_base_mv_from_fmt - procedure, pass(a) :: mold => psb_ls_base_mold + procedure, pass(a) :: csclip => psb_ls_base_csclip + procedure, pass(a) :: cp_to_coo => psb_ls_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_ls_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ls_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ls_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ls_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_ls_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ls_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ls_base_mv_from_fmt + procedure, pass(a) :: mold => psb_ls_base_mold procedure, pass(a) :: clone => psb_ls_base_clone procedure, pass(a) :: make_nonunit => psb_ls_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_ls_base_clean_zeros ! - ! Computational methods: defined here but not implemented. - ! + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_ls_base_scals procedure, pass(a) :: scalv => psb_ls_base_scal generic, public :: scal => scals, scalv @@ -292,35 +300,40 @@ module psb_s_base_mat_mod procedure, pass(a) :: arwsum => psb_ls_base_arwsum procedure, pass(a) :: colsum => psb_ls_base_colsum procedure, pass(a) :: aclsum => psb_ls_base_aclsum + procedure, pass(a) :: scalpid => psb_ls_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_ls_base_spaxpby + procedure, pass(a) :: cmpval => psb_ls_base_cmpval + procedure, pass(a) :: cmpmat => psb_ls_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_icoo => psb_ls_base_cp_to_icoo - procedure, pass(a) :: cp_from_icoo => psb_ls_base_cp_from_icoo - procedure, pass(a) :: cp_to_ifmt => psb_ls_base_cp_to_ifmt - procedure, pass(a) :: cp_from_ifmt => psb_ls_base_cp_from_ifmt - procedure, pass(a) :: mv_to_icoo => psb_ls_base_mv_to_icoo - procedure, pass(a) :: mv_from_icoo => psb_ls_base_mv_from_icoo - procedure, pass(a) :: mv_to_ifmt => psb_ls_base_mv_to_ifmt - procedure, pass(a) :: mv_from_ifmt => psb_ls_base_mv_from_ifmt - + procedure, pass(a) :: cp_to_icoo => psb_ls_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_ls_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_ls_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_ls_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_ls_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_ls_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_ls_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_ls_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. ! - ! Transpose methods: defined here but not implemented. - ! procedure, pass(a) :: transp_1mat => psb_ls_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_ls_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_ls_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_ls_base_transc_2mat - + end type psb_ls_base_sparse_mat - + private :: ls_base_mat_sync, ls_base_mat_is_host, ls_base_mat_is_dev, & & ls_base_mat_is_sync, ls_base_mat_set_host, ls_base_mat_set_dev,& & ls_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_ls_coo_sparse_mat !! \extends psb_ls_base_mat_mod::psb_ls_base_sparse_mat - !! + !! !! psb_ls_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -334,15 +347,15 @@ module psb_s_base_mat_mod integer(psb_lpk_), allocatable :: ia(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_spk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => ls_coo_get_size procedure, pass(a) :: get_nzeros => ls_coo_get_nzeros procedure, nopass :: get_fmt => ls_coo_get_fmt @@ -360,7 +373,7 @@ module psb_s_base_mat_mod procedure, pass(a) :: mv_from_fmt => psb_ls_mv_coo_from_fmt procedure, pass(a) :: cp_to_icoo => psb_ls_cp_coo_to_icoo procedure, pass(a) :: cp_from_icoo => psb_ls_cp_coo_from_icoo - + procedure, pass(a) :: csput_a => psb_ls_coo_csput_a procedure, pass(a) :: get_diag => psb_ls_coo_get_diag procedure, pass(a) :: csgetrow => psb_ls_coo_csgetrow @@ -382,9 +395,9 @@ module psb_s_base_mat_mod procedure, pass(a) :: set_sort_status => ls_coo_set_sort_status procedure, pass(a) :: get_sort_status => ls_coo_get_sort_status - - ! Computational methods: defined here but not implemented. - ! + + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_ls_coo_scals procedure, pass(a) :: scalv => psb_ls_coo_scal procedure, pass(a) :: maxval => psb_ls_coo_maxval @@ -394,7 +407,10 @@ module psb_s_base_mat_mod procedure, pass(a) :: arwsum => psb_ls_coo_arwsum procedure, pass(a) :: colsum => psb_ls_coo_colsum procedure, pass(a) :: aclsum => psb_ls_coo_aclsum - + procedure, pass(a) :: scalpid => psb_ls_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_ls_coo_spaxpby + procedure, pass(a) :: cmpval => psb_ls_coo_cmpval + procedure, pass(a) :: cmpmat => psb_ls_coo_cmpmat ! ! This is COO specific ! @@ -406,25 +422,25 @@ module psb_s_base_mat_mod procedure, pass(a) :: iset_nzeros => ls_coo_iset_nzeros generic, public :: set_nzeros => iset_nzeros #endif - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => ls_coo_transp_1mat procedure, pass(a) :: transc_1mat => ls_coo_transc_1mat - + end type psb_ls_coo_sparse_mat - + private :: ls_coo_get_nzeros, ls_coo_iset_nzeros, & & ls_coo_get_fmt, ls_coo_free, ls_coo_sizeof, & & ls_coo_transp_1mat, ls_coo_transc_1mat #if defined(IPK4) && defined(LPK8) private :: ls_coo_lset_nzeros #endif - + ! == ================= ! ! BASE interfaces @@ -433,14 +449,14 @@ module psb_s_base_mat_mod !> Function csput: !! \memberof psb_s_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -453,33 +469,33 @@ module psb_s_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_csput_a end interface - - interface - subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -487,43 +503,43 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_s_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_s_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -536,33 +552,33 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_s_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_s_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -573,34 +589,34 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_s_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_s_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -621,27 +637,27 @@ module psb_s_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_s_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -650,13 +666,13 @@ module psb_s_base_mat_mod class(psb_s_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_s_base_tril end interface - + ! !> Function triu: !! \memberof psb_s_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -665,27 +681,27 @@ module psb_s_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_s_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -694,27 +710,27 @@ module psb_s_base_mat_mod class(psb_s_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_s_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_s_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_s_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_s_base_get_diag(a,d,info) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_s_base_sparse_mat @@ -724,10 +740,10 @@ module psb_s_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mold(a,b,info) - import + ! + interface + subroutine psb_s_base_mold(a,b,info) + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -739,21 +755,21 @@ module psb_s_base_mat_mod !> Function clone: !! \memberof psb_s_base_sparse_mat !! \brief Allocate and clone a class(psb_s_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_s_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_clone end interface @@ -763,18 +779,18 @@ module psb_s_base_mat_mod !> Function make_nonunit: !! \memberof psb_s_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_s_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a end subroutine psb_s_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_s_base_sparse_mat @@ -782,16 +798,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_to_coo(a,b,info) + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_s_base_sparse_mat @@ -799,16 +815,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_from_coo(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_s_base_sparse_mat @@ -817,16 +833,16 @@ module psb_s_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_to_fmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_s_base_sparse_mat @@ -835,16 +851,16 @@ module psb_s_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_from_fmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_s_base_sparse_mat @@ -852,16 +868,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_to_coo(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_s_base_sparse_mat @@ -869,16 +885,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_from_coo(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_s_base_sparse_mat @@ -887,16 +903,16 @@ module psb_s_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_to_fmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_s_base_sparse_mat @@ -905,10 +921,10 @@ module psb_s_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_from_fmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -921,16 +937,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_to_lcoo(a,b,info) + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_to_lcoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_s_base_sparse_mat @@ -938,16 +954,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_from_lcoo(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_from_lcoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_s_base_sparse_mat @@ -956,16 +972,16 @@ module psb_s_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_to_lfmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_to_lfmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_s_base_sparse_mat @@ -974,16 +990,16 @@ module psb_s_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_cp_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_s_base_cp_from_lfmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_cp_from_lfmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_s_base_sparse_mat @@ -991,16 +1007,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_to_lcoo(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_to_lcoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_s_base_sparse_mat @@ -1008,16 +1024,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_from_lcoo(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_from_lcoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_s_base_sparse_mat @@ -1026,16 +1042,16 @@ module psb_s_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_to_lfmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_to_lfmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_s_base_sparse_mat @@ -1044,10 +1060,10 @@ module psb_s_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_s_base_mv_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_s_base_mv_from_lfmt(a,b,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1056,78 +1072,78 @@ module psb_s_base_mat_mod ! - !> + !> !! \memberof psb_s_base_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_clean_zeros ! interface subroutine psb_s_base_clean_zeros(a, info) - import + import class(psb_s_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_clean_zeros end interface - + ! !> Function transp: !! \memberof psb_s_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_s_base_transp_2mat(a,b) - import + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_s_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_s_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_s_base_transc_2mat(a,b) - import + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_s_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_s_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_s_base_transp_1mat(a) - import + import class(psb_s_base_sparse_mat), intent(inout) :: a end subroutine psb_s_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_s_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_s_base_transc_1mat(a) - import + import class(psb_s_base_sparse_mat), intent(inout) :: a end subroutine psb_s_base_transc_1mat end interface - + ! !> Function csmm: !! \memberof psb_s_base_sparse_mat @@ -1146,9 +1162,9 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! ! - interface + interface subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1156,7 +1172,7 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_base_csmm end interface - + !> Function csmv: !! \memberof psb_s_base_sparse_mat !! \brief Product by a dense rank 1 array. @@ -1174,9 +1190,9 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1184,7 +1200,7 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_base_csmv end interface - + !> Function vect_mv: !! \memberof psb_s_base_sparse_mat !! \brief Product by an encapsulated array type(psb_s_vect_type) @@ -1196,7 +1212,7 @@ module psb_s_base_mat_mod !! versions with the standard arrays. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1209,9 +1225,9 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x @@ -1220,7 +1236,7 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_base_vect_mv end interface - + ! !> Function cssm: !! \memberof psb_s_base_sparse_mat @@ -1229,7 +1245,7 @@ module psb_s_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssm. + !! Internal workhorse called by cssm. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1241,9 +1257,9 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1251,8 +1267,8 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_base_inner_cssm end interface - - + + ! !> Function cssv: !! \memberof psb_s_base_sparse_mat @@ -1261,7 +1277,7 @@ module psb_s_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssv. + !! Internal workhorse called by cssv. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1273,12 +1289,12 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface - subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1286,7 +1302,7 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_base_inner_cssv end interface - + ! !> Function inner_vect_cssv: !! \memberof psb_s_base_sparse_mat @@ -1296,10 +1312,10 @@ module psb_s_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by vect_cssv. + !! Internal workhorse called by vect_cssv. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1311,9 +1327,9 @@ module psb_s_base_mat_mod !! \param trans [N] Whether to use A (N), its transpose (T) !! or its conjugate transpose (C) ! - interface - subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x, y @@ -1321,7 +1337,7 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_base_inner_vect_sv end interface - + ! !> Function cssm: !! \memberof psb_s_base_sparse_mat @@ -1340,12 +1356,12 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1354,7 +1370,7 @@ module psb_s_base_mat_mod real(psb_spk_), intent(in), optional :: d(:) end subroutine psb_s_base_cssm end interface - + ! !> Function cssv: !! \memberof psb_s_base_sparse_mat @@ -1373,12 +1389,12 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1387,7 +1403,7 @@ module psb_s_base_mat_mod real(psb_spk_), intent(in), optional :: d(:) end subroutine psb_s_base_cssv end interface - + ! !> Function vect_cssv: !! \memberof psb_s_base_sparse_mat @@ -1407,12 +1423,12 @@ module psb_s_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. + !! \param D [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x,y @@ -1421,24 +1437,24 @@ module psb_s_base_mat_mod class(psb_s_base_vect_type), optional, intent(inout) :: d end subroutine psb_s_base_vect_cssv end interface - + ! !> Function base_scals: !! \memberof psb_s_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_s_base_scals(d,a,info) - import + interface + subroutine psb_s_base_scals(d,a,info) + import class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_scals end interface - + ! !> Function base_scal: !! \memberof psb_s_base_sparse_mat @@ -1448,40 +1464,125 @@ module psb_s_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_s_base_scal(d,a,info,side) - import + interface + subroutine psb_s_base_scal(d,a,info,side) + import class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_s_base_scal end interface - + + ! + !> Function base_scalplusidentity: + !! \memberof psb_s_base_sparse_mat + !! \brief Scale a matrix by a vector and sums an identity + !! + !! \param d Scaling + !! \param info return code + ! + interface + subroutine psb_s_base_scalplusidentity(d,a,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_scalplusidentity + end interface + + ! + !> Function base_spaxpby: + !! \memberof psb_s_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_s_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_spaxpby + end interface + + ! + !> Function base_cmpval: + !! \memberof psb_s_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_s_base_cmpval(a,val,tol,info) result(res) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_s_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_s_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_s_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_s_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_s_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_s_base_maxval(a) result(res) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_s_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_s_base_csnmi(a) result(res) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_base_csnmi @@ -1492,11 +1593,11 @@ module psb_s_base_mat_mod !> Function base_csnmi: !! \memberof psb_s_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_s_base_csnm1(a) result(res) - import + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_base_csnm1 @@ -1508,11 +1609,11 @@ module psb_s_base_mat_mod !! \memberof psb_s_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_s_base_rowsum(d,a) - import + interface + subroutine psb_s_base_rowsum(d,a) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_rowsum @@ -1523,26 +1624,26 @@ module psb_s_base_mat_mod !! \memberof psb_s_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_s_base_arwsum(d,a) - import + !! + interface + subroutine psb_s_base_arwsum(d,a) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_s_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_s_base_colsum(d,a) - import + interface + subroutine psb_s_base_colsum(d,a) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_colsum @@ -1553,16 +1654,16 @@ module psb_s_base_mat_mod !! \memberof psb_s_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_s_base_aclsum(d,a) - import + !! + interface + subroutine psb_s_base_aclsum(d,a) + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_aclsum end interface - + ! == =============== ! ! COO interfaces @@ -1570,76 +1671,76 @@ module psb_s_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_s_coo_reallocate_nz(nz,a) - import + subroutine psb_s_coo_reallocate_nz(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a end subroutine psb_s_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_s_coo_sparse_mat ! interface - subroutine psb_s_coo_ensure_size(nz,a) - import + subroutine psb_s_coo_ensure_size(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a end subroutine psb_s_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_s_coo_reinit(a,clear) - import - class(psb_s_coo_sparse_mat), intent(inout) :: a + import + class(psb_s_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_coo_reinit end interface ! - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_s_coo_trim(a) - import + import class(psb_s_coo_sparse_mat), intent(inout) :: a end subroutine psb_s_coo_trim end interface ! - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_clean_zeros ! interface subroutine psb_s_coo_clean_zeros(a,info) - import + import class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_clean_zeros end interface ! - !> + !> !! \memberof psb_s_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_s_coo_clean_negidx(a,info) - import + import class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_clean_negidx @@ -1655,11 +1756,11 @@ module psb_s_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) @@ -1668,34 +1769,34 @@ module psb_s_base_mat_mod end subroutine psb_s_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner - + ! - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_ipk_), intent(in) :: m,n class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_s_coo_allocate_mnnz end interface - + !> \memberof psb_s_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_s_coo_mold(a,b,info) - import + interface + subroutine psb_s_coo_mold(a,b,info) + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_s_coo_sparse_mat @@ -1710,17 +1811,17 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_s_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_s_coo_sparse_mat @@ -1729,16 +1830,16 @@ module psb_s_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_s_coo_get_nz_row(idx,a) result(res) - import + import class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res end function psb_s_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -1750,12 +1851,12 @@ module psb_s_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) @@ -1764,162 +1865,162 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_s_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_s_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_s_fix_coo(a,info,idir) - import + interface + subroutine psb_s_fix_coo(a,info,idir) + import class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_s_fix_coo end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo - interface - subroutine psb_s_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_s_cp_coo_to_coo(a,b,info) + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo - interface - subroutine psb_s_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_s_cp_coo_from_coo(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_from_coo end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo - interface - subroutine psb_s_cp_coo_to_lcoo(a,b,info) - import + interface + subroutine psb_s_cp_coo_to_lcoo(a,b,info) + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_to_lcoo end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo - interface - subroutine psb_s_cp_coo_from_lcoo(a,b,info) - import + interface + subroutine psb_s_cp_coo_from_lcoo(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_from_lcoo end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo - !! - interface - subroutine psb_s_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_s_cp_coo_to_fmt(a,b,info) + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_fmt - !! - interface - subroutine psb_s_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_s_cp_coo_from_fmt(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_to_coo - interface - subroutine psb_s_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_s_mv_coo_to_coo(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo - interface - subroutine psb_s_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_s_mv_coo_from_coo(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_to_fmt - interface - subroutine psb_s_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_s_mv_coo_to_fmt(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt - interface - subroutine psb_s_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_s_mv_coo_from_fmt(a,b,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_s_coo_cp_from(a,b) - import + import class(psb_s_coo_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat), intent(in) :: b end subroutine psb_s_coo_cp_from end interface - - interface + + interface subroutine psb_s_coo_mv_from(a,b) - import + import class(psb_s_coo_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat), intent(inout) :: b end subroutine psb_s_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_s_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -1936,9 +2037,9 @@ module psb_s_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1946,14 +2047,14 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_csput_a end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1965,14 +2066,14 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_coo_csgetptn end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csgetrow - interface + interface subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1985,13 +2086,13 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_coo_csgetrow end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssv - interface - subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1999,12 +2100,12 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_coo_cssv end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssm - interface - subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -2012,13 +2113,13 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_coo_cssm end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csmv - interface - subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -2027,12 +2128,12 @@ module psb_s_base_mat_mod end subroutine psb_s_coo_csmv end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csmm - interface - subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -2040,121 +2141,173 @@ module psb_s_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_coo_csmm end interface - - - !> + + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_maxval - interface + interface function psb_s_coo_maxval(a) result(res) - import + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_coo_maxval end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csnmi - interface + interface function psb_s_coo_csnmi(a) result(res) - import + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_coo_csnmi end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csnm1 - interface + interface function psb_s_coo_csnm1(a) result(res) - import + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_coo_csnm1 end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_rowsum - interface - subroutine psb_s_coo_rowsum(d,a) - import + interface + subroutine psb_s_coo_rowsum(d,a) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_rowsum end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_arwsum - interface - subroutine psb_s_coo_arwsum(d,a) - import + interface + subroutine psb_s_coo_arwsum(d,a) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_arwsum end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_colsum - interface - subroutine psb_s_coo_colsum(d,a) - import + interface + subroutine psb_s_coo_colsum(d,a) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_colsum end interface - !> + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_aclsum - interface - subroutine psb_s_coo_aclsum(d,a) - import + interface + subroutine psb_s_coo_aclsum(d,a) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_aclsum end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_get_diag - interface - subroutine psb_s_coo_get_diag(a,d,info) - import + interface + subroutine psb_s_coo_get_diag(a,d,info) + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_get_diag end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scal - interface - subroutine psb_s_coo_scal(d,a,info,side) - import + interface + subroutine psb_s_coo_scal(d,a,info,side) + import class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_s_coo_scal end interface - - !> + + !> !! \memberof psb_s_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scals interface - subroutine psb_s_coo_scals(d,a,info) - import + subroutine psb_s_coo_scals(d,a,info) + import class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_scals end interface - + !> + !! \memberof psb_s_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_scalplusidentity + interface + subroutine psb_s_coo_scalplusidentity(d,a,info) + import + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_coo_scalplusidentity + end interface + ! + !! \memberof psb_s_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_spaxpby + interface + subroutine psb_s_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_coo_spaxpby + end interface + + ! + !! \memberof psb_s_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_cmpval + interface + function psb_s_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_s_coo_cmpval + end interface + + ! + !! \memberof psb_s_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_cmpmat + interface + function psb_s_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_s_coo_cmpmat + end interface + ! == ================= ! ! BASE interfaces @@ -2163,14 +2316,14 @@ module psb_s_base_mat_mod !> Function csput: !! \memberof psb_ls_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -2183,33 +2336,33 @@ module psb_s_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_csput_a end interface - - interface - subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2217,43 +2370,43 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_ls_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_ls_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -2266,33 +2419,33 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_ls_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_ls_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_lpk_), intent(in) :: imin,imax @@ -2303,34 +2456,34 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_ls_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_ls_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -2351,27 +2504,27 @@ module psb_s_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ls_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -2380,13 +2533,13 @@ module psb_s_base_mat_mod class(psb_ls_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_ls_base_tril end interface - + ! !> Function triu: !! \memberof psb_ls_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -2395,27 +2548,27 @@ module psb_s_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ls_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -2424,27 +2577,27 @@ module psb_s_base_mat_mod class(psb_ls_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_ls_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_ls_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_ls_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_ls_base_get_diag(a,d,info) + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_ls_base_sparse_mat @@ -2454,10 +2607,10 @@ module psb_s_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mold(a,b,info) - import + ! + interface + subroutine psb_ls_base_mold(a,b,info) + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2469,21 +2622,21 @@ module psb_s_base_mat_mod !> Function clone: !! \memberof psb_ls_base_sparse_mat !! \brief Allocate and clone a class(psb_ls_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_ls_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_clone end interface @@ -2493,18 +2646,18 @@ module psb_s_base_mat_mod !> Function make_nonunit: !! \memberof psb_ls_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_ls_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a end subroutine psb_ls_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_ls_base_sparse_mat @@ -2512,16 +2665,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_to_coo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_ls_base_sparse_mat @@ -2529,16 +2682,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_from_coo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2547,16 +2700,16 @@ module psb_s_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_to_fmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2565,16 +2718,16 @@ module psb_s_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_from_fmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_ls_base_sparse_mat @@ -2582,16 +2735,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_to_coo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_ls_base_sparse_mat @@ -2599,16 +2752,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_from_coo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2617,16 +2770,16 @@ module psb_s_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_to_fmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2635,17 +2788,17 @@ module psb_s_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_from_fmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_from_fmt end interface - + ! !> Function cp_to_coo: !! \memberof psb_ls_base_sparse_mat @@ -2653,16 +2806,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_to_icoo(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_to_icoo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_to_icoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_ls_base_sparse_mat @@ -2670,16 +2823,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_from_icoo(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_from_icoo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_from_icoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2688,16 +2841,16 @@ module psb_s_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_to_ifmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_to_ifmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2706,16 +2859,16 @@ module psb_s_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_cp_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_cp_from_ifmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_cp_from_ifmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_ls_base_sparse_mat @@ -2723,16 +2876,16 @@ module psb_s_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_to_icoo(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_to_icoo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_to_icoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_ls_base_sparse_mat @@ -2740,16 +2893,16 @@ module psb_s_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_from_icoo(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_from_icoo(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_from_icoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2758,16 +2911,16 @@ module psb_s_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_to_ifmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_mv_to_ifmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_ls_base_sparse_mat @@ -2776,10 +2929,10 @@ module psb_s_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_ls_base_mv_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_ls_base_mv_from_ifmt(a,b,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2789,111 +2942,150 @@ module psb_s_base_mat_mod ! - !> + !> !! \memberof psb_ls_base_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros ! interface subroutine psb_ls_base_clean_zeros(a, info) - import + import class(psb_ls_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_clean_zeros end interface - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_maxval - interface + interface function psb_ls_coo_maxval(a) result(res) - import + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_coo_maxval end interface - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_csnmi - interface + interface function psb_ls_coo_csnmi(a) result(res) - import + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_coo_csnmi end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_csnm1 - interface + interface function psb_ls_coo_csnm1(a) result(res) - import + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_coo_csnm1 end interface - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_rowsum - interface - subroutine psb_ls_coo_rowsum(d,a) - import + interface + subroutine psb_ls_coo_rowsum(d,a) + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_coo_rowsum end interface - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_arwsum - interface - subroutine psb_ls_coo_arwsum(d,a) - import + interface + subroutine psb_ls_coo_arwsum(d,a) + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_coo_arwsum end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_colsum - interface - subroutine psb_ls_coo_colsum(d,a) - import + interface + subroutine psb_ls_coo_colsum(d,a) + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_coo_colsum end interface - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_aclsum - interface - subroutine psb_ls_coo_aclsum(d,a) - import + interface + subroutine psb_ls_coo_aclsum(d,a) + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_coo_aclsum end interface - + ! !> Function base_scals: !! \memberof psb_ls_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_ls_base_scals(d,a,info) - import + interface + subroutine psb_ls_base_scals(d,a,info) + import class(psb_ls_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_base_scals end interface - + + ! + !> Function base_scalsplusidentity: + !! \memberof psb_ls_base_sparse_mat + !! \brief Scale a matrix by a single scalar value and adds identity + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_ls_base_scalplusidentity(d,a,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_scalplusidentity + end interface + ! + !> Function base_spaxpby: + !! \memberof psb_ls_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_ls_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_spaxpby + end interface + + ! !> Function base_scal: !! \memberof psb_ls_base_sparse_mat @@ -2903,40 +3095,86 @@ module psb_s_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_ls_base_scal(d,a,info,side) - import + interface + subroutine psb_ls_base_scal(d,a,info,side) + import class(psb_ls_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_ls_base_scal end interface - + + ! + !> Function base_cmpval: + !! \memberof psb_ls_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_ls_base_cmpval(a,val,tol,info) result(res) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ls_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_ls_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_ls_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ls_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_ls_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_ls_base_maxval(a) result(res) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_ls_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_ls_base_csnmi(a) result(res) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_base_csnmi @@ -2947,11 +3185,11 @@ module psb_s_base_mat_mod !> Function base_csnmi: !! \memberof psb_ls_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_ls_base_csnm1(a) result(res) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_base_csnm1 @@ -2963,11 +3201,11 @@ module psb_s_base_mat_mod !! \memberof psb_ls_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_ls_base_rowsum(d,a) - import + interface + subroutine psb_ls_base_rowsum(d,a) + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_base_rowsum @@ -2978,26 +3216,26 @@ module psb_s_base_mat_mod !! \memberof psb_ls_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_ls_base_arwsum(d,a) - import + !! + interface + subroutine psb_ls_base_arwsum(d,a) + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_ls_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_ls_base_colsum(d,a) - import + interface + subroutine psb_ls_base_colsum(d,a) + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_base_colsum @@ -3008,76 +3246,76 @@ module psb_s_base_mat_mod !! \memberof psb_ls_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_ls_base_aclsum(d,a) - import + !! + interface + subroutine psb_ls_base_aclsum(d,a) + import class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_base_aclsum end interface - + ! !> Function transp: !! \memberof psb_ls_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_ls_base_transp_2mat(a,b) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_ls_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_ls_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_ls_base_transc_2mat(a,b) - import + import class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_ls_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_ls_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_ls_base_transp_1mat(a) - import + import class(psb_ls_base_sparse_mat), intent(inout) :: a end subroutine psb_ls_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_ls_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_ls_base_transc_1mat(a) - import + import class(psb_ls_base_sparse_mat), intent(inout) :: a end subroutine psb_ls_base_transc_1mat end interface - + ! == =============== ! ! COO interfaces @@ -3085,82 +3323,82 @@ module psb_s_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_ls_coo_reallocate_nz(nz,a) - import + subroutine psb_ls_coo_reallocate_nz(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_ls_coo_sparse_mat), intent(inout) :: a end subroutine psb_ls_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_ls_coo_sparse_mat ! interface - subroutine psb_ls_coo_ensure_size(nz,a) - import + subroutine psb_ls_coo_ensure_size(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_ls_coo_sparse_mat), intent(inout) :: a end subroutine psb_ls_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_ls_coo_reinit(a,clear) - import - class(psb_ls_coo_sparse_mat), intent(inout) :: a + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ls_coo_reinit end interface ! - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_ls_coo_trim(a) - import + import class(psb_ls_coo_sparse_mat), intent(inout) :: a end subroutine psb_ls_coo_trim end interface ! - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros ! interface subroutine psb_ls_coo_clean_zeros(a,info) - import + import class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_coo_clean_zeros end interface - + ! - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_ls_coo_clean_negidx(a,info) - import + import class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_coo_clean_negidx end interface -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) ! !> Funtion: coo_clean_negidx_inner !! \brief Take out any entries with negative row or column index @@ -3171,11 +3409,11 @@ module psb_s_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) @@ -3183,34 +3421,34 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner -#endif +#endif ! - !> + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_lpk_), intent(in) :: m,n class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_ls_coo_allocate_mnnz end interface - + !> \memberof psb_ls_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ls_coo_mold(a,b,info) - import + interface + subroutine psb_ls_coo_mold(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_ls_coo_sparse_mat @@ -3225,17 +3463,17 @@ module psb_s_base_mat_mod ! interface subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ls_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_ls_coo_sparse_mat @@ -3244,16 +3482,16 @@ module psb_s_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_ls_coo_get_nz_row(idx,a) result(res) - import + import class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res end function psb_ls_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -3265,12 +3503,12 @@ module psb_s_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_lpk_), intent(in) :: nr,nc,nzin integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -3280,164 +3518,164 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_ls_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_ls_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_ls_fix_coo(a,info,idir) - import + interface + subroutine psb_ls_fix_coo(a,info,idir) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_ls_fix_coo end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo - interface - subroutine psb_ls_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_ls_cp_coo_to_coo(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo - interface - subroutine psb_ls_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_ls_cp_coo_from_coo(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_coo_from_coo end interface - - - !> + + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo - interface - subroutine psb_ls_cp_coo_to_icoo(a,b,info) - import + interface + subroutine psb_ls_cp_coo_to_icoo(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_coo_to_icoo end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo - interface - subroutine psb_ls_cp_coo_from_icoo(a,b,info) - import + interface + subroutine psb_ls_cp_coo_from_icoo(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_coo_from_icoo end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo - !! - interface - subroutine psb_ls_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_ls_cp_coo_to_fmt(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt - !! - interface - subroutine psb_ls_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_ls_cp_coo_from_fmt(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo - interface - subroutine psb_ls_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_ls_mv_coo_to_coo(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo - interface - subroutine psb_ls_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_ls_mv_coo_from_coo(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt - interface - subroutine psb_ls_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_ls_mv_coo_to_fmt(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt - interface - subroutine psb_ls_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_ls_mv_coo_from_fmt(a,b,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_ls_coo_cp_from(a,b) - import + import class(psb_ls_coo_sparse_mat), intent(inout) :: a type(psb_ls_coo_sparse_mat), intent(in) :: b end subroutine psb_ls_coo_cp_from end interface - - interface + + interface subroutine psb_ls_coo_mv_from(a,b) - import + import class(psb_ls_coo_sparse_mat), intent(inout) :: a type(psb_ls_coo_sparse_mat), intent(inout) :: b end subroutine psb_ls_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_ls_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -3454,9 +3692,9 @@ module psb_s_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& @@ -3464,14 +3702,14 @@ module psb_s_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_coo_csput_a end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3483,14 +3721,14 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_coo_csgetptn end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow - interface + interface subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3503,39 +3741,39 @@ module psb_s_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_coo_csgetrow end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag - interface - subroutine psb_ls_coo_get_diag(a,d,info) - import + interface + subroutine psb_ls_coo_get_diag(a,d,info) + import class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_coo_get_diag end interface - - - !> + + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scal - interface - subroutine psb_ls_coo_scal(d,a,info,side) - import + interface + subroutine psb_ls_coo_scal(d,a,info,side) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_ls_coo_scal end interface - - !> + + !> !! \memberof psb_ls_coo_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scals interface - subroutine psb_ls_coo_scals(d,a,info) - import + subroutine psb_ls_coo_scals(d,a,info) + import class(psb_ls_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3543,11 +3781,64 @@ module psb_s_base_mat_mod end interface public :: psb_s_get_print_frmt, psb_ls_get_print_frmt - + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scalplusidentity + interface + subroutine psb_ls_coo_scalplusidentity(d,a,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_scalplusidentity + end interface + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_spaxpby + interface + subroutine psb_ls_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_spaxpby + end interface + + ! + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cmpval + interface + function psb_ls_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ls_coo_cmpval + end interface + + ! + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cmpmat + interface + function psb_ls_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ls_coo_cmpmat + end interface + contains - + function psb_s_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_ipk_), intent(in) :: nr, nc, nz @@ -3562,17 +3853,17 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_s_get_print_frmt - + function psb_ls_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_lpk_), intent(in) :: nr, nc, nz @@ -3587,109 +3878,109 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_ls_get_print_frmt - - + + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function s_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function s_coo_sizeof - - + + function s_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function s_coo_get_fmt - - + + function s_coo_get_size(a) result(res) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function s_coo_get_size - - + + function s_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%nnz end function s_coo_get_nzeros - + function s_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function s_coo_is_by_rows - + function s_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function s_coo_is_by_cols - + function s_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function s_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3697,52 +3988,52 @@ contains ! ! ! == ================================== - + subroutine s_coo_set_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine s_coo_set_nzeros - + function s_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_s_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function s_coo_get_sort_status - + subroutine s_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_s_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine s_coo_set_sort_status - - + + subroutine s_coo_set_by_rows(a) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine s_coo_set_by_rows - - + + subroutine s_coo_set_by_cols(a) - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine s_coo_set_by_cols - + ! == ================================== ! ! @@ -3754,12 +4045,12 @@ contains ! ! ! == ================================== - - subroutine s_coo_free(a) - implicit none - + + subroutine s_coo_free(a) + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -3768,13 +4059,13 @@ contains call a%set_ncols(0_psb_ipk_) call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine s_coo_free - - - + + + ! == ================================== ! ! @@ -3788,132 +4079,132 @@ contains ! ! == ================================== subroutine s_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a - - integer(psb_ipk_), allocatable :: itemp(:) + + integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_s_base_sparse_mat%psb_base_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine s_coo_transp_1mat - + subroutine s_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_s_is_complex_) a%val(:) = (a%val(:)) end subroutine s_coo_transc_1mat - + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function ls_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_lp res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function ls_coo_sizeof - - + + function ls_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function ls_coo_get_fmt - - + + function ls_coo_get_size(a) result(res) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function ls_coo_get_size - - + + function ls_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%nnz end function ls_coo_get_nzeros - + function ls_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function ls_coo_is_by_rows - + function ls_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function ls_coo_is_by_cols - + function ls_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function ls_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3921,63 +4212,63 @@ contains ! ! ! == ================================== - + subroutine ls_coo_iset_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_ls_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine ls_coo_iset_nzeros #if defined(IPK4) && defined(LPK8) subroutine ls_coo_lset_nzeros(nz,a) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ls_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine ls_coo_lset_nzeros #endif - + function ls_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_ls_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function ls_coo_get_sort_status - + subroutine ls_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_ls_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine ls_coo_set_sort_status - - + + subroutine ls_coo_set_by_rows(a) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine ls_coo_set_by_rows - - + + subroutine ls_coo_set_by_cols(a) - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine ls_coo_set_by_cols - + ! == ================================== ! ! @@ -3989,12 +4280,12 @@ contains ! ! ! == ================================== - - subroutine ls_coo_free(a) - implicit none - + + subroutine ls_coo_free(a) + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -4003,13 +4294,13 @@ contains call a%set_ncols(0_psb_lpk_) call a%set_nzeros(0_psb_lpk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine ls_coo_free - - - + + + ! == ================================== ! ! @@ -4023,40 +4314,37 @@ contains ! ! == ================================== subroutine ls_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a - - integer(psb_lpk_), allocatable :: itemp(:) + + integer(psb_lpk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_ls_base_sparse_mat%psb_lbase_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine ls_coo_transp_1mat - + subroutine ls_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_ls_is_complex_) a%val(:) = (a%val(:)) end subroutine ls_coo_transc_1mat end module psb_s_base_mat_mod - - - diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 2d716290b..01851abf2 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_s_base_vect_mod ! ! This module contains the definition of the psb_s_base_vect type which ! is a container for dense vectors. -! This is encapsulated instead of being just a simple array to allow for +! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran ! side. It is also meant to be encapsulated in an outer type, to allow @@ -43,7 +43,7 @@ ! ! module psb_s_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_s_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_s_base_vect_type - !! The psb_s_base_vect_type + !! The psb_s_base_vect_type !! defines a middle level real(psb_spk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow @@ -61,9 +61,9 @@ module psb_s_base_vect_mod !! sparse matrix types. !! type psb_s_base_vect_type - !> Values. + !> Values. real(psb_spk_), allocatable :: v(:) - real(psb_spk_), allocatable :: combuf(:) + real(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_s_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => s_base_ins_a procedure, pass(x) :: ins_v => s_base_ins_v @@ -93,7 +93,7 @@ module psb_s_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => s_base_sync procedure, pass(x) :: is_host => s_base_is_host @@ -130,7 +130,7 @@ module psb_s_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => s_base_gthab procedure, pass(x) :: gthzv => s_base_gthzv @@ -151,7 +151,9 @@ module psb_s_base_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => s_base_axpby_v procedure, pass(y) :: axpby_a => s_base_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => s_base_axpby_v2 + procedure, pass(z) :: axpby_a2 => s_base_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 ! ! Vector by vector multiplication. Need all variants ! to handle multiple requirements from preconditioners @@ -162,7 +164,24 @@ module psb_s_base_vect_mod procedure, pass(z) :: mlt_v_2 => s_base_mlt_v_2 procedure, pass(z) :: mlt_va => s_base_mlt_va procedure, pass(z) :: mlt_av => s_base_mlt_av - generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va + generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, & + mlt_va + ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => s_base_div_v + procedure, pass(x) :: div_v_check => s_base_div_v_check + procedure, pass(z) :: div_v2 => s_base_div_v2 + procedure, pass(z) :: div_v2_check => s_base_div_v2_check + procedure, pass(z) :: div_a2 => s_base_div_a2 + procedure, pass(z) :: div_a2_check => s_base_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => s_base_inv_v + procedure, pass(y) :: inv_v_check => s_base_inv_v_check + procedure, pass(y) :: inv_a2 => s_base_inv_a2 + procedure, pass(y) :: inv_a2_check => s_base_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check ! ! Scaling and norms ! @@ -174,6 +193,29 @@ module psb_s_base_vect_mod procedure, pass(x) :: amax => s_base_amax procedure, pass(x) :: asum => s_base_asum + ! + ! Comparison and mask operation + ! + procedure, pass(z) :: acmp_a2 => s_base_acmp_a2 + procedure, pass(z) :: acmp_v2 => s_base_acmp_v2 + generic, public :: acmp => acmp_a2,acmp_v2 + ! + ! Add constant value to all entry of a vector + ! + procedure, pass(z) :: addconst_a2 => s_base_addconst_a2 + procedure, pass(z) :: addconst_v2 => s_base_addconst_v2 + generic, public :: addconst => addconst_a2,addconst_v2 + + procedure, pass(x) :: minreal => s_base_min + procedure, pass(m) :: mask_v => s_base_mask_v + procedure, pass(m) :: mask_a => s_base_mask_a + generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => s_base_minquotient_v + procedure, pass(x) :: minquotient_a2 => s_base_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 + + + end type psb_s_base_vect_type public :: psb_s_base_vect @@ -183,11 +225,11 @@ module psb_s_base_vect_mod end interface psb_s_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +242,11 @@ contains this%v = x call this%asb(size(x,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +256,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +268,20 @@ contains !! subroutine s_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none real(psb_spk_), intent(in) :: this(:) class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine s_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +289,11 @@ contains !> Function bld_mn: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine s_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +302,15 @@ contains call x%asb(n,info) end subroutine s_base_bld_mn - + !> Function bld_en: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine s_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +319,24 @@ contains call x%asb(n,info) end subroutine s_base_bld_en - + !> Function base_all: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine s_base_all(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_base_vect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(n,x%v,info) - + end subroutine s_base_all !> Function base_mold: @@ -306,11 +348,11 @@ contains subroutine s_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x class(psb_s_base_vect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_s_base_vect_type :: y, stat=info) end subroutine s_base_mold @@ -320,21 +362,21 @@ contains ! !> Function base_ins: !! \memberof psb_s_base_vect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -344,7 +386,7 @@ contains ! subroutine s_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +396,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -376,7 +418,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +436,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +445,7 @@ contains subroutine s_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +455,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() call x%ins(n,irl%v,val%v,dupl,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +478,14 @@ contains ! subroutine s_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=szero call x%set_host() end subroutine s_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +494,20 @@ contains !> Function base_asb: !! \memberof psb_s_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine s_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +524,20 @@ contains !> Function base_asb: !! \memberof psb_s_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine s_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +550,39 @@ contains !> Function base_free: !! \memberof psb_s_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine s_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if (info == 0) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine s_base_free - + ! !> Function base_free_buffer: !! \memberof psb_s_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine s_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +597,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine s_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +617,13 @@ contains !> Function base_free_comid: !! \memberof psb_s_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine s_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +635,77 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_s_base_vect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine s_base_sync(x) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x - + end subroutine s_base_sync ! !> Function base_set_host: !! \memberof psb_s_base_vect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine s_base_set_host(x) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x - + end subroutine s_base_set_host ! !> Function base_set_dev: !! \memberof psb_s_base_vect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine s_base_set_dev(x) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x - + end subroutine s_base_set_dev ! !> Function base_set_sync: !! \memberof psb_s_base_vect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine s_base_set_sync(x) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x - + end subroutine s_base_set_sync ! !> Function base_is_dev: !! \memberof psb_s_base_vect_type !! \brief Is vector on external device . - !! + !! ! function s_base_is_dev(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x logical :: res - + res = .false. end function s_base_is_dev - + ! !> Function base_is_host !! \memberof psb_s_base_vect_type !! \brief Is vector on standard memory . - !! + !! ! function s_base_is_host(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +716,10 @@ contains !> Function base_is_sync !! \memberof psb_s_base_vect_type !! \brief Is vector on sync . - !! + !! ! function s_base_is_sync(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +728,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_s_base_vect_type !! \brief Number of entries - !! + !! ! function s_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +750,13 @@ contains !> Function base_get_sizeof !! \memberof psb_s_base_vect_type !! \brief Size in bytes - !! + !! ! function s_base_sizeof(x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(in) :: x integer(psb_epk_) :: res - + ! Force 8-byte integers. res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() @@ -724,14 +766,14 @@ contains !> Function base_get_fmt !! \memberof psb_s_base_vect_type !! \brief Format - !! + !! ! function s_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function s_base_get_fmt - + ! ! @@ -740,7 +782,7 @@ contains !! \memberof psb_s_base_vect_type !! \brief Extract a copy of the contents !! - ! + ! function s_base_get_vect(x,n) result(res) class(psb_s_base_vect_type), intent(inout) :: x real(psb_spk_), allocatable :: res(:) @@ -748,21 +790,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + if (.not.allocated(x%v)) return if (.not.x%is_host()) call x%sync() isz = x%get_nrows() if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function s_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +813,18 @@ contains !! \param val The value to set !! subroutine s_base_set_scal(x,val,first,last) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_ first_=1 last_=size(x%v) if (present(first)) first_ = max(1,first) if (present(last)) last_ = min(last,last_) - + if (x%is_dev()) call x%sync() x%v(first_:last_) = val call x%set_host() @@ -794,14 +836,14 @@ contains !> Function base_set_vect !! \memberof psb_s_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine s_base_set_vect(x,val,first,last) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +851,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +871,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine s_base_absval1(x) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +883,21 @@ contains end subroutine s_base_absval1 subroutine s_base_absval2(x,y) - implicit none - class(psb_s_base_vect_type), intent(inout) :: x + implicit none + class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: y integer(psb_ipk_) :: info if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) call y%absval() end if - + end subroutine s_base_absval2 ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_s_base_vect_type @@ -864,12 +906,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function s_base_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res real(psb_spk_), external :: sdot - + res = szero ! ! Note: this is the base implementation. @@ -898,19 +940,19 @@ contains !! \param y(:) The array to be multiplied by !! function s_base_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res real(psb_spk_), external :: sdot - + res = sdot(n,y,1,x%v,1) end function s_base_dot_a - + ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +967,13 @@ contains !! subroutine s_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: y real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (x%is_dev()) call x%sync() call y%axpby(m,alpha,x%v,beta,info) @@ -939,7 +981,39 @@ contains end subroutine s_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_s_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar alpha + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + subroutine s_base_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine s_base_axpby_v2 + + ! + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +1027,50 @@ contains !! subroutine s_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent(in) :: x(:) class(psb_s_base_vect_type), intent(inout) :: y real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (y%is_dev()) call y%sync() call psb_geaxpby(m,alpha,x,beta,y%v,info) call y%set_host() - + end subroutine s_base_axpby_a - + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_s_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + subroutine s_base_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine s_base_axpby_a2 + + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +1088,10 @@ contains !! subroutine s_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1109,7 @@ contains !! subroutine s_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:) class(psb_s_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1118,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1139,7 @@ contains !! subroutine s_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) real(psb_spk_), intent(in) :: x(:) @@ -1043,58 +1147,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (z%is_dev()) call z%sync() n = min(size(z%v), size(x), size(y)) - if (alpha == szero) then - if (beta == sone) then - return + if (alpha == szero) then + if (beta == sone) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == sone) then - if (beta == szero) then - do i=1, n + if (alpha == sone) then + if (beta == szero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == sone) then - do i=1, n + else if (beta == sone) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + y(i)*x(i) end do end if - else if (alpha == -sone) then - if (beta == szero) then - do i=1, n + else if (alpha == -sone) then + if (beta == szero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == sone) then - do i=1, n + else if (beta == sone) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == szero) then - do i=1, n + if (beta == szero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == sone) then - do i=1, n + else if (beta == sone) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1222,12 @@ contains subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: y class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1237,7 @@ contains if (x%is_dev()) call x%sync() if (.not.psb_s_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1252,12 @@ contains subroutine s_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: x(:) class(psb_s_base_vect_type), intent(inout) :: y class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1268,12 @@ contains subroutine s_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1281,318 @@ contains call z%mlt(alpha,y,x,beta,info) end subroutine s_base_mlt_va + ! + !> Function base_div_v + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine s_base_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info) + + + end subroutine s_base_div_v + ! + !> Function base_div_v2 + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine s_base_div_v2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + end subroutine s_base_div_v2 + ! + !> Function base_div_v_check + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine s_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine s_base_div_v_check + ! + !> Function base_div_v2_check + !! \memberof psb_s_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine s_base_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + + end subroutine s_base_div_v2_check + ! + !> Function base_div_a2 + !! \memberof psb_s_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + subroutine s_base_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine s_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine s_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: z + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call s_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + + end subroutine s_base_div_a2_check + ! + !> Function base_inv_v + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + subroutine s_base_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine s_base_inv_v + ! + !> Function base_inv_v_check + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + subroutine s_base_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + + end subroutine s_base_inv_v_check + ! + !> Function base_inv_a2 + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + subroutine s_base_inv_a2(x, y, info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + y%v(i) = 1_psb_spk_/x(i) + end do + + end subroutine s_base_inv_a2 + ! + !> Function base_inv_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + subroutine s_base_inv_a2_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call s_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_spk_/x(i) + else + info = 1 + y%v(i) = 0_psb_spk_ + end if + end do + end if + + + end subroutine s_base_inv_a2_check ! - ! Simple scaling + !> Function base_inv_a2_check + !! \memberof psb_s_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine s_base_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_spk_ + else + z%v(i) = 0_psb_spk_ + end if + end do + info = 0 + + end subroutine s_base_acmp_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_s_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine s_base_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: c + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine s_base_acmp_v2 + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_s_base_vect_type @@ -1189,17 +1601,17 @@ contains !! subroutine s_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine s_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,50 +1620,122 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function s_base_nrm2(n,x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res real(psb_spk_), external :: snrm2 - + if (x%is_dev()) call x%sync() res = snrm2(n,x%v,1) end function s_base_nrm2 - + ! !> Function base_amax !! \memberof psb_s_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function s_base_amax(n,x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) end function s_base_amax + ! + !> Function base_min + !! \memberof psb_s_base_vect_type + !! \brief min x(1:n) + !! \param n how many entries to consider + function s_base_min(n,x) result(res) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (x%is_dev()) call x%sync() + res = minval(x%v(1:n)) + + end function s_base_min + + ! + !> Function base_minquotient_v + !! \memberof psb_s_base_vect_type + !! \brief Minimum entry of the vector entry-by-entry divide x/y + !! \param x The numerator vector + !! \param y The denumerator vector + !! \param info return code + !! + function s_base_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + if (y%is_dev()) call y%sync() + + z = x%minquotient(y%v,info) + + end function s_base_minquotient_v + + ! + !> Function base_minquotient_a2 + !! \memberof psb_s_base_vect_type + !! \brief Minimum entry of the array entry-by-entry divide x/y + !! \param x The numerator array + !! \param y The denumerator array + !! \param info return code + !! + function s_base_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + real(psb_spk_) :: temp + + info = 0 + + z = huge(z) + n = min(size(y), size(x%v)) + do i=1, n + if ( y(i) /= szero ) then + temp = x%v(i)/y(i) + if (temp <= z) z = temp + end if + end do + + end function s_base_minquotient_a2 + + ! !> Function base_asum !! \memberof psb_s_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function s_base_asum(n,x) result(res) - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function s_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1750,18 @@ contains !! \param beta subroutine s_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: alpha, beta, y(:) class(psb_s_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,alpha,x%v,beta,y) end subroutine s_base_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_s_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1286,28 +1770,28 @@ contains !! \param idx(:) indices subroutine s_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: y(:) class(psb_s_base_vect_type) :: x - + if (idx%is_dev()) call idx%sync() call x%gth(n,idx%v(i:),y) end subroutine s_base_gthzv_x ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine s_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_s_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1804,22 @@ contains !> Function base_device_wait: !! \memberof psb_s_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine s_base_device_wait() - implicit none - + implicit none + end subroutine s_base_device_wait function s_base_use_buffer() result(res) logical :: res - + res = .true. end function s_base_use_buffer subroutine s_base_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1829,7 @@ contains subroutine s_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1840,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_s_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1849,20 @@ contains !! \param idx(:) indices subroutine s_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: y(:) class(psb_s_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,x%v,y) end subroutine s_base_gthzv ! - ! Scatter: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_s_base_vect_type @@ -1387,14 +1871,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine s_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:) class(psb_s_base_vect_type) :: y - + if (y%is_dev()) call y%sync() call psi_sct(n,idx,x,beta,y%v) call y%set_host() @@ -1403,12 +1887,12 @@ contains subroutine s_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: beta, x(:) class(psb_s_base_vect_type) :: y - + if (idx%is_dev()) call idx%sync() call y%sct(n,idx%v(i:),x,beta) call y%set_host() @@ -1417,14 +1901,14 @@ contains subroutine s_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: beta class(psb_s_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1435,6 +1919,147 @@ contains end subroutine s_base_sctb_buf + ! + !> Function base_mask_a + !! \memberof psb_s_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The array to be compared + !! \param c The array containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + subroutine s_base_mask_a(c,x,m,t,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(inout) :: c(:) + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + integer(psb_ipk_) :: i, n + + if (m%is_dev()) call m%sync() + t = .true. + + n = size(x) + do i = 1, n, 1 + if (c(i).eq.2_psb_spk_) then + if ( x(i) > szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + elseif (c(i).eq.1_psb_spk_) then + if ( x(i) >= szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + elseif (c(i).eq.-1_psb_spk_) then + if ( x(i) <= szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + elseif (c(i).eq.-2_psb_spk_) then + if ( x(i) < szero ) then + m%v(i) = 0_psb_spk_ + else + m%v(i) = 1_psb_spk_ + t = .false. + end if + else + m%v(i) = 0_psb_spk_ + end if + end do + info = 0 + + end subroutine s_base_mask_a + ! + !> Function base_mask_v + !! \memberof psb_s_base_vect_type + !! \brief Peform constraint tests looking at the value of c + !! \param x The vector to be compared + !! \param c The vector containing the information on the type of test to be + !! performed, if c(i) = 2 ">0", if c(i) = 1 ">=0", if c(i) = 0 no test, if + !! c(i) =-1 "<=0", if c(i) = -2 "< 0" + !! \param m The vector containing the result of the comparison 1.0 for a + !! failed test, and 0.0 for a passed one. + !! \param t logical resulting from an and operation on all the tests + !! \param info return code + ! + subroutine s_base_mask_v(c,x,m,t,info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: c + class(psb_s_base_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: t + + info = 0 + if (x%is_dev()) call x%sync() + if (c%is_dev()) call c%sync() + + call m%mask(x%v,c%v,t,info) + end subroutine s_base_mask_v + + + ! + !> Function _base_addconst_a2 + !! \memberof psb_s_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine s_base_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: b + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + z%v(i) = x(i) + b + end do + info = 0 + + end subroutine s_base_addconst_a2 + ! + !> Function _base_addconst_v2 + !! \memberof psb_s_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine s_base_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + real(psb_spk_), intent(in) :: b + class(psb_s_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine s_base_addconst_v2 end module psb_s_base_vect_mod @@ -1449,22 +2074,22 @@ module psb_s_base_multivect_mod use psb_s_base_vect_mod !> \namespace psb_base_mod \class psb_s_base_vect_type - !! The psb_s_base_vect_type + !! The psb_s_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private + private public :: psb_s_base_multivect, psb_s_base_multivect_type type psb_s_base_multivect_type - !> Values. + !> Values. real(psb_spk_), allocatable :: v(:,:) - real(psb_spk_), allocatable :: combuf(:) + real(psb_spk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +2103,7 @@ module psb_s_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => s_base_mlv_ins procedure, pass(x) :: zero => s_base_mlv_zero @@ -1489,7 +2114,7 @@ module psb_s_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => s_base_mlv_sync procedure, pass(x) :: is_host => s_base_mlv_is_host @@ -1562,7 +2187,7 @@ module psb_s_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => s_base_mlv_gthab procedure, pass(x) :: gthzv => s_base_mlv_gthzv @@ -1584,7 +2209,7 @@ module psb_s_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +2228,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +2255,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +2270,7 @@ contains !> Function bld_n: !! \memberof psb_s_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine s_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +2287,13 @@ contains !! \memberof psb_s_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine s_base_mlv_all(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +2311,7 @@ contains subroutine s_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x class(psb_s_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info @@ -1700,21 +2325,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_s_base_multivect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -1724,7 +2349,7 @@ contains ! subroutine s_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +2359,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -1756,7 +2381,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +2398,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +2413,7 @@ contains ! subroutine s_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=szero @@ -1804,7 +2429,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_s_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +2438,7 @@ contains subroutine s_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +2455,20 @@ contains !> Function base_mlv_free: !! \memberof psb_s_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine s_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine s_base_mlv_free @@ -1853,15 +2478,15 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_mlv_sync: !! \memberof psb_s_base_multivect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine s_base_mlv_sync(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_sync @@ -1870,10 +2495,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_s_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine s_base_mlv_set_host(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_set_host @@ -1882,10 +2507,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_s_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine s_base_mlv_set_dev(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_set_dev @@ -1894,10 +2519,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_s_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine s_base_mlv_set_sync(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x end subroutine s_base_mlv_set_sync @@ -1906,10 +2531,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_s_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function s_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +2545,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_s_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function s_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +2559,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_s_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function s_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +2571,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_s_base_multivect_type !! \brief Number of entries - !! + !! ! function s_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2590,7 @@ contains end function s_base_mlv_get_nrows function s_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2603,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_s_base_multivect_type !! \brief Size in bytesa - !! + !! ! function s_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2619,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_s_base_multivect_type !! \brief Format - !! + !! ! function s_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function s_base_mlv_get_fmt @@ -2010,18 +2635,18 @@ contains !! \memberof psb_s_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function s_base_mlv_get_vect(x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), allocatable :: res(:,:) integer(psb_ipk_) :: info,m,n m = x%get_nrows() n = x%get_ncols() - if (.not.allocated(x%v)) return + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2654,7 @@ contains end function s_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2663,7 @@ contains !! \param val The value to set !! subroutine s_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val @@ -2051,16 +2676,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_s_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine s_base_mlv_set_vect(x,val) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_) :: nr, nc integer(psb_ipk_) :: info - if (allocated(x%v)) then + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2697,8 @@ contains end subroutine s_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_s_base_multivect_type @@ -2082,7 +2707,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function s_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2094,7 +2719,7 @@ contains ! ! Note: this is the base implementation. ! When we get here, we are sure that X is of - ! TYPE psb_s_base_mlv_vect (or its class does not care). + ! TYPE psb_s_base_mlv_vect (or its class does not care). ! If Y is not, throw the burden on it, implicitly ! calling dot_a ! @@ -2123,7 +2748,7 @@ contains !! \param y(:) The array to be multiplied by !! function s_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2766,7 @@ contains end function s_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2781,7 @@ contains !! subroutine s_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_s_base_multivect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: y @@ -2180,7 +2805,7 @@ contains end subroutine s_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2819,7 @@ contains !! subroutine s_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent(in) :: x(:,:) class(psb_s_base_multivect_type), intent(inout) :: y @@ -2230,10 +2855,10 @@ contains !! subroutine s_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2868,10 @@ contains subroutine s_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_s_base_vect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2888,7 @@ contains !! subroutine s_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:) class(psb_s_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2896,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2911,7 @@ contains !! subroutine s_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:,:) class(psb_s_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2938,7 @@ contains !! subroutine s_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:,:) real(psb_spk_), intent(in) :: x(:,:) @@ -2321,38 +2946,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + info = 0 nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == szero) then - if (beta == sone) then - return + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == szero) then + if (beta == sone) then + return else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) end if else - if (alpha == sone) then - if (beta == szero) then + if (alpha == sone) then + if (beta == szero) then z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == sone) then + else if (beta == sone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) end if - else if (alpha == -sone) then - if (beta == szero) then + else if (alpha == -sone) then + if (beta == szero) then z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == sone) then + else if (beta == sone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) end if else - if (beta == szero) then + if (beta == szero) then z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == sone) then + else if (beta == sone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) end if end if @@ -2373,12 +2998,12 @@ contains subroutine s_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta class(psb_s_base_multivect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: y class(psb_s_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +3014,7 @@ contains if (z%is_dev()) call z%sync() if (.not.psb_s_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +3029,39 @@ contains !!$ !!$ subroutine s_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_base_multivect_type), intent(inout) :: y !!$ class(psb_s_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,x,y%v,beta,info) !!$ !!$ end subroutine s_base_mlv_mlt_av !!$ !!$ subroutine s_base_mlv_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: y(:) !!$ class(psb_s_base_multivect_type), intent(inout) :: x !!$ class(psb_s_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,y,x,beta,info) !!$ !!$ end subroutine s_base_mlv_mlt_va !!$ !!$ ! - ! Simple scaling + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_s_base_multivect_type @@ -2445,7 +3070,7 @@ contains !! subroutine s_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha @@ -2462,7 +3087,7 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function s_base_mlv_nrm2(n,x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2484,7 +3109,7 @@ contains !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function s_base_mlv_amax(n,x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2505,7 +3130,7 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function s_base_mlv_asum(n,x) result(res) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_), allocatable :: res(:) @@ -2528,7 +3153,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine s_base_mlv_absval1(x) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +3165,13 @@ contains end subroutine s_base_mlv_absval1 subroutine s_base_mlv_absval2(x,y) - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x class(psb_s_base_multivect_type), intent(inout) :: y integer(psb_ipk_) :: info - + if (x%is_dev()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),sone,x,szero,info) call y%absval() end if @@ -2555,15 +3180,15 @@ contains function s_base_mlv_use_buffer() result(res) - implicit none + implicit none logical :: res - + res = .true. end function s_base_mlv_use_buffer subroutine s_base_mlv_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +3200,7 @@ contains subroutine s_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +3211,12 @@ contains subroutine s_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +3224,7 @@ contains subroutine s_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +3234,7 @@ contains subroutine s_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_s_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +3257,7 @@ contains !! \param beta subroutine s_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: alpha, beta, y(:) class(psb_s_base_multivect_type) :: x @@ -2648,7 +3273,7 @@ contains end subroutine s_base_mlv_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_s_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2657,7 +3282,7 @@ contains !! \param idx(:) indices subroutine s_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: y(:) @@ -2670,7 +3295,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_s_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2679,7 +3304,7 @@ contains !! \param idx(:) indices subroutine s_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: y(:) class(psb_s_base_multivect_type) :: x @@ -2696,7 +3321,7 @@ contains end subroutine s_base_mlv_gthzv ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_s_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2705,7 +3330,7 @@ contains !! \param idx(:) indices subroutine s_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: y(:,:) class(psb_s_base_multivect_type) :: x @@ -2722,17 +3347,17 @@ contains end subroutine s_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine s_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_s_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +3369,9 @@ contains end subroutine s_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_s_base_multivect_type @@ -2755,10 +3380,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine s_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:) class(psb_s_base_multivect_type) :: y @@ -2773,7 +3398,7 @@ contains subroutine s_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) real(psb_spk_) :: beta, x(:,:) class(psb_s_base_multivect_type) :: y @@ -2788,7 +3413,7 @@ contains subroutine s_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx real( psb_spk_) :: beta, x(:) @@ -2800,14 +3425,14 @@ contains subroutine s_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n class(psb_i_base_vect_type) :: idx real(psb_spk_) :: beta class(psb_s_base_multivect_type) :: y integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +3441,18 @@ contains nc = y%get_ncols() call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) call y%set_host() - + end subroutine s_base_mlv_sctb_buf ! !> Function base_device_wait: !! \memberof psb_s_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine s_base_mlv_device_wait() - implicit none - + implicit none + end subroutine s_base_mlv_device_wait end module psb_s_base_multivect_mod - diff --git a/base/modules/serial/psb_s_csc_mat_mod.f90 b/base/modules/serial/psb_s_csc_mat_mod.f90 index 30841854d..ccd4f4457 100644 --- a/base/modules/serial/psb_s_csc_mat_mod.f90 +++ b/base/modules/serial/psb_s_csc_mat_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_s_csc_mat_mod ! @@ -40,23 +40,23 @@ ! ! Please refere to psb_s_base_mat_mod for a detailed description ! of the various methods, and to psb_s_csc_impl for implementation details. -! +! module psb_s_csc_mat_mod use psb_s_base_mat_mod !> \namespace psb_base_mod \class psb_s_csc_sparse_mat !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat - !! + !! !! psb_s_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_s_base_sparse_mat) :: psb_s_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_ipk_), allocatable :: icp(:) !> Row indices. integer(psb_ipk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. real(psb_spk_), allocatable :: val(:) contains @@ -107,16 +107,16 @@ module psb_s_csc_mat_mod !> \namespace psb_base_mod \class psb_s_csc_sparse_mat !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat - !! + !! !! psb_s_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_ls_base_sparse_mat) :: psb_ls_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_lpk_), allocatable :: icp(:) !> Row indices. integer(psb_lpk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. real(psb_spk_), allocatable :: val(:) contains @@ -163,23 +163,23 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_s_csc_reallocate_nz(nz,a) + subroutine psb_s_csc_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_s_csc_sparse_mat), intent(inout) :: a end subroutine psb_s_csc_reallocate_nz end interface - + !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_s_csc_reinit(a,clear) import - class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_csc_reinit end interface - + !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -188,22 +188,22 @@ module psb_s_csc_mat_mod class(psb_s_csc_sparse_mat), intent(inout) :: a end subroutine psb_s_csc_trim end interface - + !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_s_csc_mold(a,b,info) + interface + subroutine psb_s_csc_mold(a,b,info) import class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csc_mold end interface - + !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -211,147 +211,147 @@ module psb_s_csc_mat_mod end subroutine psb_s_csc_allocate_mnnz end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_print interface subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_s_csc_print end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo - interface - subroutine psb_s_cp_csc_to_coo(a,b,info) + interface + subroutine psb_s_cp_csc_to_coo(a,b,info) import class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csc_to_coo end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo - interface - subroutine psb_s_cp_csc_from_coo(a,b,info) + interface + subroutine psb_s_cp_csc_from_coo(a,b,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csc_from_coo end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_to_fmt - interface - subroutine psb_s_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_s_cp_csc_to_fmt(a,b,info) import class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csc_to_fmt end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_fmt - interface - subroutine psb_s_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_s_cp_csc_from_fmt(a,b,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csc_from_fmt end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_to_coo - interface - subroutine psb_s_mv_csc_to_coo(a,b,info) + interface + subroutine psb_s_mv_csc_to_coo(a,b,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csc_to_coo end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo - interface - subroutine psb_s_mv_csc_from_coo(a,b,info) + interface + subroutine psb_s_mv_csc_from_coo(a,b,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csc_from_coo end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_to_fmt - interface - subroutine psb_s_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_s_mv_csc_to_fmt(a,b,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csc_to_fmt end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt - interface - subroutine psb_s_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_s_mv_csc_from_fmt(a,b,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_clean_zeros ! interface subroutine psb_s_csc_clean_zeros(a, info) - import + import class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csc_clean_zeros end interface - - + + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from - interface + interface subroutine psb_s_csc_cp_from(a,b) import class(psb_s_csc_sparse_mat), intent(inout) :: a type(psb_s_csc_sparse_mat), intent(in) :: b end subroutine psb_s_csc_cp_from end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from - interface + interface subroutine psb_s_csc_mv_from(a,b) import class(psb_s_csc_sparse_mat), intent(inout) :: a type(psb_s_csc_sparse_mat), intent(inout) :: b end subroutine psb_s_csc_mv_from end interface - - + + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csput_a - interface - subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -360,10 +360,10 @@ module psb_s_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csc_csput_a end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -378,10 +378,10 @@ module psb_s_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_csc_csgetptn end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csgetrow - interface + interface subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ @@ -400,7 +400,7 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csgetblk - interface + interface subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) import @@ -414,11 +414,11 @@ module psb_s_csc_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_csc_csgetblk end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssv - interface - subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -429,8 +429,8 @@ module psb_s_csc_mat_mod end interface !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssm - interface - subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -439,11 +439,11 @@ module psb_s_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_csc_cssm end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csmv - interface - subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -455,8 +455,8 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csmm - interface - subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -465,21 +465,21 @@ module psb_s_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_csc_csmm end interface - - + + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_maxval - interface + interface function psb_s_csc_maxval(a) result(res) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csc_maxval end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csnm1 - interface + interface function psb_s_csc_csnm1(a) result(res) import class(psb_s_csc_sparse_mat), intent(in) :: a @@ -489,8 +489,8 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_rowsum - interface - subroutine psb_s_csc_rowsum(d,a) + interface + subroutine psb_s_csc_rowsum(d,a) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -499,18 +499,18 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_arwsum - interface - subroutine psb_s_csc_arwsum(d,a) + interface + subroutine psb_s_csc_arwsum(d,a) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csc_arwsum end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_colsum - interface - subroutine psb_s_csc_colsum(d,a) + interface + subroutine psb_s_csc_colsum(d,a) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -519,29 +519,29 @@ module psb_s_csc_mat_mod !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_aclsum - interface - subroutine psb_s_csc_aclsum(d,a) + interface + subroutine psb_s_csc_aclsum(d,a) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csc_aclsum end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_get_diag - interface - subroutine psb_s_csc_get_diag(a,d,info) + interface + subroutine psb_s_csc_get_diag(a,d,info) import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csc_get_diag end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scal - interface - subroutine psb_s_csc_scal(d,a,info,side) + interface + subroutine psb_s_csc_scal(d,a,info,side) import class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) @@ -549,42 +549,41 @@ module psb_s_csc_mat_mod character, intent(in), optional :: side end subroutine psb_s_csc_scal end interface - + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scals interface - subroutine psb_s_csc_scals(d,a,info) + subroutine psb_s_csc_scals(d,a,info) import class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csc_scals end interface - ! ! ls - ! + ! !> \memberof psb_ls_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_ls_csc_reallocate_nz(nz,a) + subroutine psb_ls_csc_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_ls_csc_sparse_mat), intent(inout) :: a end subroutine psb_ls_csc_reallocate_nz end interface - + !> \memberof psb_ls_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_ls_csc_reinit(a,clear) import - class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ls_csc_reinit end interface - + !> \memberof psb_ls_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -593,22 +592,22 @@ module psb_s_csc_mat_mod class(psb_ls_csc_sparse_mat), intent(inout) :: a end subroutine psb_ls_csc_trim end interface - + !> \memberof psb_ls_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ls_csc_mold(a,b,info) + interface + subroutine psb_ls_csc_mold(a,b,info) import class(psb_ls_csc_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csc_mold end interface - + !> \memberof psb_ls_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_ls_csc_sparse_mat), intent(inout) :: a @@ -616,146 +615,146 @@ module psb_s_csc_mat_mod end subroutine psb_ls_csc_allocate_mnnz end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_print interface subroutine psb_ls_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ls_csc_print end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo - interface - subroutine psb_ls_cp_csc_to_coo(a,b,info) + interface + subroutine psb_ls_cp_csc_to_coo(a,b,info) import class(psb_ls_csc_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csc_to_coo end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo - interface - subroutine psb_ls_cp_csc_from_coo(a,b,info) + interface + subroutine psb_ls_cp_csc_from_coo(a,b,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csc_from_coo end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_fmt - interface - subroutine psb_ls_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_ls_cp_csc_to_fmt(a,b,info) import class(psb_ls_csc_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csc_to_fmt end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt - interface - subroutine psb_ls_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_ls_cp_csc_from_fmt(a,b,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csc_from_fmt end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo - interface - subroutine psb_ls_mv_csc_to_coo(a,b,info) + interface + subroutine psb_ls_mv_csc_to_coo(a,b,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csc_to_coo end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo - interface - subroutine psb_ls_mv_csc_from_coo(a,b,info) + interface + subroutine psb_ls_mv_csc_from_coo(a,b,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csc_from_coo end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt - interface - subroutine psb_ls_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_ls_mv_csc_to_fmt(a,b,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csc_to_fmt end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt - interface - subroutine psb_ls_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_ls_mv_csc_from_fmt(a,b,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros ! interface subroutine psb_ls_csc_clean_zeros(a, info) - import + import class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csc_clean_zeros end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from - interface + interface subroutine psb_ls_csc_cp_from(a,b) import class(psb_ls_csc_sparse_mat), intent(inout) :: a type(psb_ls_csc_sparse_mat), intent(in) :: b end subroutine psb_ls_csc_cp_from end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from - interface + interface subroutine psb_ls_csc_mv_from(a,b) import class(psb_ls_csc_sparse_mat), intent(inout) :: a type(psb_ls_csc_sparse_mat), intent(inout) :: b end subroutine psb_ls_csc_mv_from end interface - - + + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a - interface - subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -764,10 +763,10 @@ module psb_s_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csc_csput_a end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_ls_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -782,10 +781,10 @@ module psb_s_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csc_csgetptn end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow - interface + interface subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -804,7 +803,7 @@ module psb_s_csc_mat_mod !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_csgetblk - interface + interface subroutine psb_ls_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import @@ -818,31 +817,31 @@ module psb_s_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csc_csgetblk end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag - interface - subroutine psb_ls_csc_get_diag(a,d,info) + interface + subroutine psb_ls_csc_get_diag(a,d,info) import class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csc_get_diag end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_maxval - interface + interface function psb_ls_csc_maxval(a) result(res) import class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_csc_maxval end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_csnm1 - interface + interface function psb_ls_csc_csnm1(a) result(res) import class(psb_ls_csc_sparse_mat), intent(in) :: a @@ -852,8 +851,8 @@ module psb_s_csc_mat_mod !> \memberof psb_ls_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_rowsum - interface - subroutine psb_ls_csc_rowsum(d,a) + interface + subroutine psb_ls_csc_rowsum(d,a) import class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -862,18 +861,18 @@ module psb_s_csc_mat_mod !> \memberof psb_ls_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_arwsum - interface - subroutine psb_ls_csc_arwsum(d,a) + interface + subroutine psb_ls_csc_arwsum(d,a) import class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_csc_arwsum end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_colsum - interface - subroutine psb_ls_csc_colsum(d,a) + interface + subroutine psb_ls_csc_colsum(d,a) import class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -882,18 +881,18 @@ module psb_s_csc_mat_mod !> \memberof psb_ls_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_aclsum - interface - subroutine psb_ls_csc_aclsum(d,a) + interface + subroutine psb_ls_csc_aclsum(d,a) import class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_csc_aclsum end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scal - interface - subroutine psb_ls_csc_scal(d,a,info,side) + interface + subroutine psb_ls_csc_scal(d,a,info,side) import class(psb_ls_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) @@ -901,27 +900,25 @@ module psb_s_csc_mat_mod character, intent(in), optional :: side end subroutine psb_ls_csc_scal end interface - + !> \memberof psb_ls_csc_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scals interface - subroutine psb_ls_csc_scals(d,a,info) + subroutine psb_ls_csc_scals(d,a,info) import class(psb_ls_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csc_scals end interface - - -contains +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -929,54 +926,54 @@ contains ! ! == =================================== - + function s_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function s_csc_is_by_cols - + function s_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%icp) res = res + psb_sizeof_ip * psb_size(a%ia) - + end function s_csc_sizeof function s_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function s_csc_get_fmt - + function s_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%icp(a%get_ncols()+1)-1 end function s_csc_get_nzeros function s_csc_get_size(a) result(res) - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -988,17 +985,17 @@ contains function s_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function s_csc_get_nz_col @@ -1013,11 +1010,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine s_csc_free(a) - implicit none + subroutine s_csc_free(a) + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a @@ -1027,7 +1024,7 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine s_csc_free @@ -1038,7 +1035,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1046,57 +1043,57 @@ contains ! ! == =================================== - + function ls_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function ls_csc_is_by_cols ! ! ls ! - + function ls_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2*psb_sizeof_lp res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%icp) res = res + psb_sizeof_lp * psb_size(a%ia) - + end function ls_csc_sizeof function ls_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function ls_csc_get_fmt - + function ls_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%icp(a%get_ncols()+1)-1 end function ls_csc_get_nzeros function ls_csc_get_size(a) result(res) - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1108,17 +1105,17 @@ contains function ls_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_ls_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function ls_csc_get_nz_col @@ -1133,11 +1130,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine ls_csc_free(a) - implicit none + subroutine ls_csc_free(a) + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a @@ -1147,7 +1144,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine ls_csc_free diff --git a/base/modules/serial/psb_s_csr_mat_mod.f90 b/base/modules/serial/psb_s_csr_mat_mod.f90 index 5dd0871f5..6b4c51c79 100644 --- a/base/modules/serial/psb_s_csr_mat_mod.f90 +++ b/base/modules/serial/psb_s_csr_mat_mod.f90 @@ -1,10 +1,10 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -16,7 +16,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -28,8 +28,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_s_csr_mat_mod ! @@ -48,17 +48,17 @@ module psb_s_csr_mat_mod !> \namespace psb_base_mod \class psb_s_csr_sparse_mat !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat - !! + !! !! psb_s_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_s_base_sparse_mat) :: psb_s_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_ipk_), allocatable :: irp(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_spk_), allocatable :: val(:) contains @@ -112,23 +112,23 @@ module psb_s_csr_mat_mod !> \memberof psb_s_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_s_csr_reallocate_nz(nz,a) + subroutine psb_s_csr_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_s_csr_sparse_mat), intent(inout) :: a end subroutine psb_s_csr_reallocate_nz end interface - + !> \memberof psb_s_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_s_csr_reinit(a,clear) import - class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_csr_reinit end interface - + !> \memberof psb_s_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -138,22 +138,22 @@ module psb_s_csr_mat_mod end subroutine psb_s_csr_trim end interface - + !> \memberof psb_s_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_s_csr_mold(a,b,info) + interface + subroutine psb_s_csr_mold(a,b,info) import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csr_mold end interface - + !> \memberof psb_s_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -161,14 +161,14 @@ module psb_s_csr_mat_mod end subroutine psb_s_csr_allocate_mnnz end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_print interface subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -187,27 +187,27 @@ module psb_s_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_s_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -216,13 +216,13 @@ module psb_s_csr_mat_mod class(psb_s_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_s_csr_tril end interface - + ! !> Function triu: !! \memberof psb_s_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -231,27 +231,27 @@ module psb_s_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_s_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -260,133 +260,133 @@ module psb_s_csr_mat_mod class(psb_s_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_s_csr_triu end interface - + ! - !> + !> !! \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_clean_zeros ! interface subroutine psb_s_csr_clean_zeros(a, info) - import + import class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csr_clean_zeros end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo - interface - subroutine psb_s_cp_csr_to_coo(a,b,info) + interface + subroutine psb_s_cp_csr_to_coo(a,b,info) import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csr_to_coo end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo - interface - subroutine psb_s_cp_csr_from_coo(a,b,info) + interface + subroutine psb_s_cp_csr_from_coo(a,b,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csr_from_coo end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_to_fmt - interface - subroutine psb_s_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_s_cp_csr_to_fmt(a,b,info) import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csr_to_fmt end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from_fmt - interface - subroutine psb_s_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_s_cp_csr_from_fmt(a,b,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csr_from_fmt end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_to_coo - interface - subroutine psb_s_mv_csr_to_coo(a,b,info) + interface + subroutine psb_s_mv_csr_to_coo(a,b,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csr_to_coo end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo - interface - subroutine psb_s_mv_csr_from_coo(a,b,info) + interface + subroutine psb_s_mv_csr_from_coo(a,b,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csr_from_coo end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_to_fmt - interface - subroutine psb_s_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_s_mv_csr_to_fmt(a,b,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csr_to_fmt end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt - interface - subroutine psb_s_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_s_mv_csr_from_fmt(a,b,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_mv_csr_from_fmt end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cp_from - interface + interface subroutine psb_s_csr_cp_from(a,b) import class(psb_s_csr_sparse_mat), intent(inout) :: a type(psb_s_csr_sparse_mat), intent(in) :: b end subroutine psb_s_csr_cp_from end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_mv_from - interface + interface subroutine psb_s_csr_mv_from(a,b) import class(psb_s_csr_sparse_mat), intent(inout) :: a type(psb_s_csr_sparse_mat), intent(inout) :: b end subroutine psb_s_csr_mv_from end interface - - + + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csput_a - interface - subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -395,10 +395,10 @@ module psb_s_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csr_csput_a end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -413,10 +413,10 @@ module psb_s_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_csr_csgetptn end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csgetrow - interface + interface subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import @@ -435,8 +435,8 @@ module psb_s_csr_mat_mod !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssv - interface - subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -447,8 +447,8 @@ module psb_s_csr_mat_mod end interface !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssm - interface - subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -457,11 +457,11 @@ module psb_s_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_csr_cssm end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csmv - interface - subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -473,8 +473,8 @@ module psb_s_csr_mat_mod !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csmm - interface - subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -483,32 +483,32 @@ module psb_s_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_csr_csmm end interface - - + + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_maxval - interface + interface function psb_s_csr_maxval(a) result(res) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csr_maxval end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_csnmi - interface + interface function psb_s_csr_csnmi(a) result(res) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csr_csnmi end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_rowsum - interface - subroutine psb_s_csr_rowsum(d,a) + interface + subroutine psb_s_csr_rowsum(d,a) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -517,18 +517,18 @@ module psb_s_csr_mat_mod !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_arwsum - interface - subroutine psb_s_csr_arwsum(d,a) + interface + subroutine psb_s_csr_arwsum(d,a) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csr_arwsum end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_colsum - interface - subroutine psb_s_csr_colsum(d,a) + interface + subroutine psb_s_csr_colsum(d,a) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -537,29 +537,29 @@ module psb_s_csr_mat_mod !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_aclsum - interface - subroutine psb_s_csr_aclsum(d,a) + interface + subroutine psb_s_csr_aclsum(d,a) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csr_aclsum end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_get_diag - interface - subroutine psb_s_csr_get_diag(a,d,info) + interface + subroutine psb_s_csr_get_diag(a,d,info) import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csr_get_diag end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scal - interface - subroutine psb_s_csr_scal(d,a,info,side) + interface + subroutine psb_s_csr_scal(d,a,info,side) import class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) @@ -567,32 +567,31 @@ module psb_s_csr_mat_mod character, intent(in), optional :: side end subroutine psb_s_csr_scal end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_scals interface - subroutine psb_s_csr_scals(d,a,info) + subroutine psb_s_csr_scals(d,a,info) import class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csr_scals end interface - !> \namespace psb_base_mod \class psb_ls_csr_sparse_mat !! \extends psb_ls_base_mat_mod::psb_ls_base_sparse_mat - !! + !! !! psb_ls_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_ls_base_sparse_mat) :: psb_ls_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_lpk_), allocatable :: irp(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. real(psb_spk_), allocatable :: val(:) contains @@ -642,23 +641,23 @@ module psb_s_csr_mat_mod !> \memberof psb_ls_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_ls_csr_reallocate_nz(nz,a) + subroutine psb_ls_csr_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_ls_csr_sparse_mat), intent(inout) :: a end subroutine psb_ls_csr_reallocate_nz end interface - + !> \memberof psb_ls_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_ls_csr_reinit(a,clear) import - class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ls_csr_reinit end interface - + !> \memberof psb_ls_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -668,22 +667,22 @@ module psb_s_csr_mat_mod end subroutine psb_ls_csr_trim end interface - + !> \memberof psb_ls_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_ls_csr_mold(a,b,info) + interface + subroutine psb_ls_csr_mold(a,b,info) import class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csr_mold end interface - + !> \memberof psb_ls_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_ls_csr_sparse_mat), intent(inout) :: a @@ -691,14 +690,14 @@ module psb_s_csr_mat_mod end subroutine psb_ls_csr_allocate_mnnz end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_print interface subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -717,27 +716,27 @@ module psb_s_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ls_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -746,13 +745,13 @@ module psb_s_csr_mat_mod class(psb_ls_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_ls_csr_tril end interface - + ! !> Function triu: !! \memberof psb_s_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -761,27 +760,27 @@ module psb_s_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_ls_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -792,133 +791,133 @@ module psb_s_csr_mat_mod end interface ! - !> + !> !! \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros ! interface subroutine psb_ls_csr_clean_zeros(a, info) - import + import class(psb_ls_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csr_clean_zeros end interface - - + + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo - interface - subroutine psb_ls_cp_csr_to_coo(a,b,info) + interface + subroutine psb_ls_cp_csr_to_coo(a,b,info) import class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csr_to_coo end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo - interface - subroutine psb_ls_cp_csr_from_coo(a,b,info) + interface + subroutine psb_ls_cp_csr_from_coo(a,b,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csr_from_coo end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_fmt - interface - subroutine psb_ls_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_ls_cp_csr_to_fmt(a,b,info) import class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csr_to_fmt end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt - interface - subroutine psb_ls_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_ls_cp_csr_from_fmt(a,b,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_cp_csr_from_fmt end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo - interface - subroutine psb_ls_mv_csr_to_coo(a,b,info) + interface + subroutine psb_ls_mv_csr_to_coo(a,b,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csr_to_coo end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo - interface - subroutine psb_ls_mv_csr_from_coo(a,b,info) + interface + subroutine psb_ls_mv_csr_from_coo(a,b,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csr_from_coo end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt - interface - subroutine psb_ls_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_ls_mv_csr_to_fmt(a,b,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csr_to_fmt end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt - interface - subroutine psb_ls_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_ls_mv_csr_from_fmt(a,b,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_mv_csr_from_fmt end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from - interface + interface subroutine psb_ls_csr_cp_from(a,b) import class(psb_ls_csr_sparse_mat), intent(inout) :: a type(psb_ls_csr_sparse_mat), intent(in) :: b end subroutine psb_ls_csr_cp_from end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from - interface + interface subroutine psb_ls_csr_mv_from(a,b) import class(psb_ls_csr_sparse_mat), intent(inout) :: a type(psb_ls_csr_sparse_mat), intent(inout) :: b end subroutine psb_ls_csr_mv_from end interface - - + + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a - interface - subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -927,10 +926,10 @@ module psb_s_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csr_csput_a end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -945,10 +944,10 @@ module psb_s_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csr_csgetptn end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow - interface + interface subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -964,11 +963,11 @@ module psb_s_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csr_csgetrow end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag - interface - subroutine psb_ls_csr_get_diag(a,d,info) + interface + subroutine psb_ls_csr_get_diag(a,d,info) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -978,8 +977,8 @@ module psb_s_csr_mat_mod !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scal - interface - subroutine psb_ls_csr_scal(d,a,info,side) + interface + subroutine psb_ls_csr_scal(d,a,info,side) import class(psb_ls_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) @@ -987,42 +986,42 @@ module psb_s_csr_mat_mod character, intent(in), optional :: side end subroutine psb_ls_csr_scal end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_ls_base_mat_mod::psb_ls_base_scals interface - subroutine psb_ls_csr_scals(d,a,info) + subroutine psb_ls_csr_scals(d,a,info) import class(psb_ls_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csr_scals end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_maxval - interface + interface function psb_ls_csr_maxval(a) result(res) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_csr_maxval end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_csnmi - interface + interface function psb_ls_csr_csnmi(a) result(res) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_ls_csr_csnmi end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_rowsum - interface - subroutine psb_ls_csr_rowsum(d,a) + interface + subroutine psb_ls_csr_rowsum(d,a) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -1031,18 +1030,18 @@ module psb_s_csr_mat_mod !> \memberof psb_ls_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_arwsum - interface - subroutine psb_ls_csr_arwsum(d,a) + interface + subroutine psb_ls_csr_arwsum(d,a) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_csr_arwsum end interface - + !> \memberof psb_ls_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_colsum - interface - subroutine psb_ls_csr_colsum(d,a) + interface + subroutine psb_ls_csr_colsum(d,a) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) @@ -1051,22 +1050,22 @@ module psb_s_csr_mat_mod !> \memberof psb_ls_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_ls_base_aclsum - interface - subroutine psb_ls_csr_aclsum(d,a) + interface + subroutine psb_ls_csr_aclsum(d,a) import class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_ls_csr_aclsum end interface - -contains + +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1075,54 +1074,54 @@ contains ! == =================================== - + function s_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function s_csr_is_by_rows - + function s_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function s_csr_sizeof function s_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function s_csr_get_fmt - + function s_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%irp(a%get_nrows()+1)-1 end function s_csr_get_nzeros function s_csr_get_size(a) result(res) - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1134,17 +1133,17 @@ contains function s_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function s_csr_get_nz_row @@ -1159,10 +1158,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine s_csr_free(a) - implicit none + subroutine s_csr_free(a) + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a @@ -1172,18 +1171,18 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine s_csr_free - + ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1192,54 +1191,54 @@ contains ! == =================================== - + function ls_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function ls_csr_is_by_rows - + function ls_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 2 * psb_sizeof_lp + res = 2 * psb_sizeof_lp res = res + psb_sizeof_sp * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%irp) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function ls_csr_sizeof function ls_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function ls_csr_get_fmt - + function ls_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%irp(a%get_nrows()+1)-1 end function ls_csr_get_nzeros function ls_csr_get_size(a) result(res) - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1251,17 +1250,17 @@ contains function ls_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_ls_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function ls_csr_get_nz_row @@ -1276,10 +1275,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine ls_csr_free(a) - implicit none + subroutine ls_csr_free(a) + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a @@ -1289,7 +1288,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine ls_csr_free diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 index a097f7c53..3553e96b3 100644 --- a/base/modules/serial/psb_s_mat_mod.F90 +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_s_mat_mod ! @@ -37,7 +37,7 @@ ! provide a mean of switching, at run-time, among different formats, ! potentially unknown at the library compile-time by adding a layer of ! indirection. This type encapsulates the psb_s_base_sparse_mat class -! inside another class which is the one visible to the user. +! inside another class which is the one visible to the user. ! Most methods of the psb_s_mat_mod simply call the methods of the ! encapsulated class. ! The exceptions are mainly cscnv and cp_from/cp_to; these provide @@ -48,14 +48,14 @@ ! through the application life. ! In particular, computational methods can only be invoked when ! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the ! following state transition table. Associated with these states are ! the possible dynamic types of the inner matrix object. ! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method !| ---------------------------------- !| Null Build csall !| Build Build csput @@ -64,7 +64,7 @@ !| Assembled Update reinit !| Update Update csput !| Update Assembled cscnv -!| * unchanged reall +!| * unchanged reall !| Assembled Null free ! ! @@ -74,7 +74,7 @@ ! of the indices, which are PSB_LPK_ so that the entries ! are guaranteed to be able to contain global indices. ! This type only supports data handling and preprocessing, it is -! not supposed to be used for computations. +! not supposed to be used for computations. ! module psb_s_mat_mod @@ -84,7 +84,7 @@ module psb_s_mat_mod type :: psb_sspmat_type - class(psb_s_base_sparse_mat), allocatable :: a + class(psb_s_base_sparse_mat), allocatable :: a contains ! Getters @@ -126,12 +126,12 @@ module psb_s_mat_mod procedure, pass(a) :: set_unit => psb_s_set_unit procedure, pass(a) :: set_repeatable_updates => psb_s_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_s_csall procedure, pass(a) :: free => psb_s_free procedure, pass(a) :: trim => psb_s_trim procedure, pass(a) :: csput_a => psb_s_csput_a - procedure, pass(a) :: csput_v => psb_s_csput_v + procedure, pass(a) :: csput_v => psb_s_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_s_csgetptn procedure, pass(a) :: csgetrow => psb_s_csgetrow @@ -141,7 +141,7 @@ module psb_s_mat_mod procedure, pass(a) :: lcsgetptn => psb_s_lcsgetptn procedure, pass(a) :: lcsgetrow => psb_s_lcsgetrow generic, public :: csget => lcsgetptn, lcsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_s_tril procedure, pass(a) :: triu => psb_s_triu procedure, pass(a) :: m_csclip => psb_s_csclip @@ -169,7 +169,7 @@ module psb_s_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => s_mat_sync procedure, pass(a) :: is_host => s_mat_is_host @@ -205,16 +205,16 @@ module psb_s_mat_mod procedure, pass(a) :: mv_to_lb => psb_s_mv_to_lb procedure, pass(a) :: cp_from_lb => psb_s_cp_from_lb procedure, pass(a) :: cp_to_lb => psb_s_cp_to_lb - procedure, pass(a) :: mv_from_l => psb_s_mv_from_l - procedure, pass(a) :: mv_to_l => psb_s_mv_to_l - procedure, pass(a) :: cp_from_l => psb_s_cp_from_l - procedure, pass(a) :: cp_to_l => psb_s_cp_to_l + procedure, pass(a) :: mv_from_l => psb_s_mv_from_l + procedure, pass(a) :: mv_to_l => psb_s_mv_to_l + procedure, pass(a) :: cp_from_l => psb_s_cp_from_l + procedure, pass(a) :: cp_to_l => psb_s_cp_to_l generic, public :: mv_from => mv_from_lb, mv_from_l generic, public :: mv_to => mv_to_lb, mv_to_l generic, public :: cp_from => cp_from_lb, cp_from_l generic, public :: cp_to => cp_to_lb, cp_to_l - - ! Computational routines + + ! Computational routines procedure, pass(a) :: get_diag => psb_s_get_diag procedure, pass(a) :: maxval => psb_s_maxval procedure, pass(a) :: spnmi => psb_s_csnmi @@ -234,6 +234,11 @@ module psb_s_mat_mod procedure, pass(a) :: cssv => psb_s_cssv procedure, pass(a) :: cssm => psb_s_cssm generic, public :: spsm => cssm, cssv, cssv_v + procedure, pass(a) :: scalpid => psb_s_scalplusidentity + procedure, pass(a) :: spaxpby => psb_s_spaxpby + procedure, pass(a) :: cmpval => psb_s_cmpval + procedure, pass(a) :: cmpmat => psb_s_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_sspmat_type @@ -267,7 +272,7 @@ module psb_s_mat_mod type :: psb_lsspmat_type - class(psb_ls_base_sparse_mat), allocatable :: a + class(psb_ls_base_sparse_mat), allocatable :: a contains ! Getters @@ -296,7 +301,7 @@ module psb_s_mat_mod ! Setters procedure, pass(a) :: set_lnrows => psb_ls_set_lnrows procedure, pass(a) :: set_lncols => psb_ls_set_lncols -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) procedure, pass(a) :: set_inrows => psb_ls_set_inrows procedure, pass(a) :: set_incols => psb_ls_set_incols generic, public :: set_nrows => set_inrows, set_lnrows @@ -305,7 +310,7 @@ module psb_s_mat_mod generic, public :: set_nrows => set_lnrows generic, public :: set_ncols => set_lncols #endif - + procedure, pass(a) :: set_dupl => psb_ls_set_dupl procedure, pass(a) :: set_null => psb_ls_set_null procedure, pass(a) :: set_bld => psb_ls_set_bld @@ -319,12 +324,12 @@ module psb_s_mat_mod procedure, pass(a) :: set_unit => psb_ls_set_unit procedure, pass(a) :: set_repeatable_updates => psb_ls_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_ls_csall procedure, pass(a) :: free => psb_ls_free procedure, pass(a) :: trim => psb_ls_trim procedure, pass(a) :: csput_a => psb_ls_csput_a - procedure, pass(a) :: csput_v => psb_ls_csput_v + procedure, pass(a) :: csput_v => psb_ls_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_ls_csgetptn procedure, pass(a) :: csgetrow => psb_ls_csgetrow @@ -334,7 +339,7 @@ module psb_s_mat_mod !!$ procedure, pass(a) :: icsgetptn => psb_ls_icsgetptn !!$ procedure, pass(a) :: icsgetrow => psb_ls_icsgetrow !!$ generic, public :: csget => icsgetptn, icsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_ls_tril procedure, pass(a) :: triu => psb_ls_triu procedure, pass(a) :: m_csclip => psb_ls_csclip @@ -362,7 +367,7 @@ module psb_s_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => ls_mat_sync procedure, pass(a) :: is_host => ls_mat_is_host @@ -398,16 +403,16 @@ module psb_s_mat_mod procedure, pass(a) :: mv_to_ib => psb_ls_mv_to_ib procedure, pass(a) :: cp_from_ib => psb_ls_cp_from_ib procedure, pass(a) :: cp_to_ib => psb_ls_cp_to_ib - procedure, pass(a) :: mv_from_i => psb_ls_mv_from_i - procedure, pass(a) :: mv_to_i => psb_ls_mv_to_i - procedure, pass(a) :: cp_from_i => psb_ls_cp_from_i - procedure, pass(a) :: cp_to_i => psb_ls_cp_to_i + procedure, pass(a) :: mv_from_i => psb_ls_mv_from_i + procedure, pass(a) :: mv_to_i => psb_ls_mv_to_i + procedure, pass(a) :: cp_from_i => psb_ls_cp_from_i + procedure, pass(a) :: cp_to_i => psb_ls_cp_to_i generic, public :: mv_from => mv_from_ib, mv_from_i generic, public :: mv_to => mv_to_ib, mv_to_i generic, public :: cp_from => cp_from_ib, cp_from_i generic, public :: cp_to => cp_to_ib, cp_to_i - ! Computational routines + ! Computational routines procedure, pass(a) :: get_diag => psb_ls_get_diag procedure, pass(a) :: maxval => psb_ls_maxval procedure, pass(a) :: spnmi => psb_ls_csnmi @@ -419,6 +424,11 @@ module psb_s_mat_mod procedure, pass(a) :: scals => psb_ls_scals procedure, pass(a) :: scalv => psb_ls_scal generic, public :: scal => scals, scalv + procedure, pass(a) :: scalpid => psb_ls_scalplusidentity + procedure, pass(a) :: spaxpby => psb_ls_spaxpby + procedure, pass(a) :: cmpval => psb_ls_cmpval + procedure, pass(a) :: cmpmat => psb_ls_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_lsspmat_type @@ -449,7 +459,7 @@ module psb_s_mat_mod ! ! ! - ! Setters + ! Setters ! ! ! @@ -459,142 +469,142 @@ module psb_s_mat_mod ! == =================================== - interface - subroutine psb_s_set_nrows(m,a) + interface + subroutine psb_s_set_nrows(m,a) import :: psb_ipk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_s_set_nrows end interface - - interface - subroutine psb_s_set_ncols(n,a) + + interface + subroutine psb_s_set_ncols(n,a) import :: psb_ipk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_s_set_ncols end interface - - interface - subroutine psb_s_set_dupl(n,a) + + interface + subroutine psb_s_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_s_set_dupl end interface - - interface - subroutine psb_s_set_null(a) + + interface + subroutine psb_s_set_null(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_null end interface - - interface - subroutine psb_s_set_bld(a) + + interface + subroutine psb_s_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_bld end interface - - interface - subroutine psb_s_set_upd(a) + + interface + subroutine psb_s_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_upd end interface - - interface - subroutine psb_s_set_asb(a) + + interface + subroutine psb_s_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_set_asb end interface - - interface - subroutine psb_s_set_sorted(a,val) + + interface + subroutine psb_s_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_sorted end interface - - interface - subroutine psb_s_set_triangle(a,val) + + interface + subroutine psb_s_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_triangle end interface - - interface - subroutine psb_s_set_symmetric(a,val) + + interface + subroutine psb_s_set_symmetric(a,val) import :: psb_ipk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_symmetric end interface - - interface - subroutine psb_s_set_unit(a,val) + + interface + subroutine psb_s_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_unit end interface - - interface - subroutine psb_s_set_lower(a,val) + + interface + subroutine psb_s_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_lower end interface - - interface - subroutine psb_s_set_upper(a,val) + + interface + subroutine psb_s_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_s_set_upper end interface - - interface + + interface subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_sspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_s_sparse_print end interface - interface + interface subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_sspmat_type character(len=*), intent(in) :: fname - class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_s_n_sparse_print end interface - - interface + + interface subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_sspmat_type - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev end subroutine psb_s_get_neigh end interface - - interface - subroutine psb_s_csall(nr,nc,a,info,nz) + + interface + subroutine psb_s_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc @@ -602,31 +612,31 @@ module psb_s_mat_mod integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_s_csall end interface - - interface - subroutine psb_s_reallocate_nz(nz,a) + + interface + subroutine psb_s_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_reallocate_nz end interface - - interface - subroutine psb_s_free(a) + + interface + subroutine psb_s_free(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_free end interface - - interface - subroutine psb_s_trim(a) + + interface + subroutine psb_s_trim(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_trim end interface - - interface - subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -635,9 +645,9 @@ module psb_s_mat_mod end subroutine psb_s_csput_a end interface - - interface - subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_vect_mod, only : psb_s_vect_type use psb_i_vect_mod, only : psb_i_vect_type import :: psb_ipk_, psb_lpk_, psb_sspmat_type @@ -648,8 +658,8 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csput_v end interface - - interface + + interface subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -664,8 +674,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_csgetptn end interface - - interface + + interface subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -681,8 +691,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_csgetrow end interface - - interface + + interface subroutine psb_s_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -696,8 +706,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_csgetblk end interface - - interface + + interface subroutine psb_s_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -709,8 +719,8 @@ module psb_s_mat_mod class(psb_sspmat_type), optional, intent(inout) :: u end subroutine psb_s_tril end interface - - interface + + interface subroutine psb_s_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -724,7 +734,7 @@ module psb_s_mat_mod end interface - interface + interface subroutine psb_s_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -736,7 +746,7 @@ module psb_s_mat_mod end subroutine psb_s_csclip end interface - interface + interface subroutine psb_s_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -746,8 +756,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_csclip_ip end interface - - interface + + interface subroutine psb_s_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_coo_sparse_mat @@ -758,60 +768,60 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_s_b_csclip end interface - - interface + + interface subroutine psb_s_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_s_mold end interface - - interface - subroutine psb_s_asb(a,mold) + + interface + subroutine psb_s_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_s_asb end interface - - interface + + interface subroutine psb_s_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_transp_1mat end interface - - interface + + interface subroutine psb_s_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b end subroutine psb_s_transp_2mat end interface - - interface + + interface subroutine psb_s_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a end subroutine psb_s_transc_1mat end interface - - interface + + interface subroutine psb_s_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b end subroutine psb_s_transc_2mat end interface - - interface + + interface subroutine psb_s_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_reinit - + end interface @@ -826,9 +836,9 @@ module psb_s_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(in) :: a @@ -839,9 +849,9 @@ module psb_s_mat_mod class(psb_s_base_sparse_mat), intent(in), optional :: mold end subroutine psb_s_cscnv end interface - - interface + + interface subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a @@ -851,9 +861,9 @@ module psb_s_mat_mod class(psb_s_base_sparse_mat), intent(in), optional :: mold end subroutine psb_s_cscnv_ip end interface - - interface + + interface subroutine psb_s_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(in) :: a @@ -862,12 +872,12 @@ module psb_s_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_s_cscnv_base end interface - + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_s_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(in) :: a @@ -875,46 +885,46 @@ module psb_s_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_s_clip_d end interface - - interface + + interface subroutine psb_s_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_s_clip_d_ip end interface - + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_s_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_s_mv_from end interface - - interface + + interface subroutine psb_s_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(out) :: a class(psb_s_base_sparse_mat), intent(in) :: b end subroutine psb_s_cp_from end interface - - interface + + interface subroutine psb_s_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_s_mv_to end interface - - interface + + interface subroutine psb_s_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_s_cp_to @@ -922,63 +932,63 @@ module psb_s_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_s_mv_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_s_mv_from_lb end interface - - interface + + interface subroutine psb_s_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_sspmat_type), intent(out) :: a class(psb_ls_base_sparse_mat), intent(in) :: b end subroutine psb_s_cp_from_lb end interface - - interface + + interface subroutine psb_s_mv_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_s_mv_to_lb end interface - - interface + + interface subroutine psb_s_cp_to_lb(a,b) - import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_sspmat_type), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_s_cp_to_lb end interface - interface + interface subroutine psb_s_mv_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type class(psb_sspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: b end subroutine psb_s_mv_from_l end interface - - interface + + interface subroutine psb_s_cp_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type class(psb_sspmat_type), intent(out) :: a class(psb_lsspmat_type), intent(in) :: b end subroutine psb_s_cp_from_l end interface - - interface + + interface subroutine psb_s_mv_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type class(psb_sspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: b end subroutine psb_s_mv_to_l end interface - - interface + + interface subroutine psb_s_cp_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type class(psb_sspmat_type), intent(in) :: a @@ -988,8 +998,8 @@ module psb_s_mat_mod ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_sspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a @@ -997,8 +1007,8 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_sspmat_type_move end interface - - interface + + interface subroutine psb_sspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_sspmat_type class(psb_sspmat_type), intent(inout) :: a @@ -1024,7 +1034,7 @@ module psb_s_mat_mod ! == =================================== interface psb_csmm - subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) + subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -1032,7 +1042,7 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_s_csmm - subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -1040,7 +1050,7 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_s_csmv - subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) + subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_s_vect_mod, only : psb_s_vect_type import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1051,9 +1061,9 @@ module psb_s_mat_mod character, optional, intent(in) :: trans end subroutine psb_s_csmv_vect end interface - + interface psb_cssm - subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) @@ -1062,7 +1072,7 @@ module psb_s_mat_mod character, optional, intent(in) :: trans, scale real(psb_spk_), intent(in), optional :: d(:) end subroutine psb_s_cssm - subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -1071,7 +1081,7 @@ module psb_s_mat_mod character, optional, intent(in) :: trans, scale real(psb_spk_), intent(in), optional :: d(:) end subroutine psb_s_cssv - subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_s_vect_mod, only : psb_s_vect_type import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1083,24 +1093,24 @@ module psb_s_mat_mod type(psb_s_vect_type), optional, intent(inout) :: d end subroutine psb_s_cssv_vect end interface - - interface + + interface function psb_s_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_s_maxval end interface - - interface + + interface function psb_s_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_s_csnmi end interface - - interface + + interface function psb_s_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1108,7 +1118,7 @@ module psb_s_mat_mod end function psb_s_csnm1 end interface - interface + interface function psb_s_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1117,7 +1127,7 @@ module psb_s_mat_mod end function psb_s_rowsum end interface - interface + interface function psb_s_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1125,8 +1135,8 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_s_arwsum end interface - - interface + + interface function psb_s_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1135,7 +1145,7 @@ module psb_s_mat_mod end function psb_s_colsum end interface - interface + interface function psb_s_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1144,7 +1154,7 @@ module psb_s_mat_mod end function psb_s_aclsum end interface - interface + interface function psb_s_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ class(psb_sspmat_type), intent(in) :: a @@ -1152,7 +1162,7 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_s_get_diag end interface - + interface psb_scal subroutine psb_s_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ @@ -1169,12 +1179,53 @@ module psb_s_mat_mod end subroutine psb_s_scals end interface + interface psb_scalplusidentity + subroutine psb_s_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_s_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_spaxpby + end interface + + interface + function psb_s_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_s_cmpval + end interface + + interface + function psb_s_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_s_cmpmat + end interface ! == =================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -1184,156 +1235,156 @@ module psb_s_mat_mod ! == =================================== - interface - subroutine psb_ls_set_lnrows(m,a) + interface + subroutine psb_ls_set_lnrows(m,a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m end subroutine psb_ls_set_lnrows #if defined(IPK4) && defined(LPK8) - subroutine psb_ls_set_inrows(m,a) + subroutine psb_ls_set_inrows(m,a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_ls_set_inrows #endif end interface - - interface - subroutine psb_ls_set_lncols(n,a) + + interface + subroutine psb_ls_set_lncols(n,a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n end subroutine psb_ls_set_lncols -#if defined(IPK4) && defined(LPK8) - subroutine psb_ls_set_incols(n,a) +#if defined(IPK4) && defined(LPK8) + subroutine psb_ls_set_incols(n,a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_ls_set_incols #endif end interface - - interface - subroutine psb_ls_set_dupl(n,a) + + interface + subroutine psb_ls_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_ls_set_dupl end interface - - interface - subroutine psb_ls_set_null(a) + + interface + subroutine psb_ls_set_null(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_set_null end interface - - interface - subroutine psb_ls_set_bld(a) + + interface + subroutine psb_ls_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_set_bld end interface - - interface - subroutine psb_ls_set_upd(a) + + interface + subroutine psb_ls_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_set_upd end interface - - interface - subroutine psb_ls_set_asb(a) + + interface + subroutine psb_ls_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_set_asb end interface - - interface - subroutine psb_ls_set_sorted(a,val) + + interface + subroutine psb_ls_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ls_set_sorted end interface - - interface - subroutine psb_ls_set_triangle(a,val) + + interface + subroutine psb_ls_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ls_set_triangle end interface - - interface - subroutine psb_ls_set_symmetric(a,val) + + interface + subroutine psb_ls_set_symmetric(a,val) import :: psb_ipk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ls_set_symmetric end interface - - interface - subroutine psb_ls_set_unit(a,val) + + interface + subroutine psb_ls_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ls_set_unit end interface - - interface - subroutine psb_ls_set_lower(a,val) + + interface + subroutine psb_ls_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ls_set_lower end interface - - interface - subroutine psb_ls_set_upper(a,val) + + interface + subroutine psb_ls_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_ls_set_upper end interface - - interface + + interface subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ls_sparse_print end interface - interface + interface subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type character(len=*), intent(in) :: fname - class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_ls_n_sparse_print end interface - - interface + + interface subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type - class(psb_lsspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev end subroutine psb_ls_get_neigh end interface - - interface - subroutine psb_ls_csall(nr,nc,a,info,nz) + + interface + subroutine psb_ls_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc @@ -1341,31 +1392,31 @@ module psb_s_mat_mod integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_ls_csall end interface - - interface - subroutine psb_ls_reallocate_nz(nz,a) + + interface + subroutine psb_ls_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type integer(psb_lpk_), intent(in) :: nz class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_reallocate_nz end interface - - interface - subroutine psb_ls_free(a) + + interface + subroutine psb_ls_free(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_free end interface - - interface - subroutine psb_ls_trim(a) + + interface + subroutine psb_ls_trim(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_trim end interface - - interface - subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -1374,9 +1425,9 @@ module psb_s_mat_mod end subroutine psb_ls_csput_a end interface - - interface - subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_vect_mod, only : psb_s_vect_type use psb_l_vect_mod, only : psb_l_vect_type import :: psb_ipk_, psb_lpk_, psb_lsspmat_type @@ -1387,8 +1438,8 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_csput_v end interface - - interface + + interface subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1403,8 +1454,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csgetptn end interface - - interface + + interface subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1420,8 +1471,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csgetrow end interface - - interface + + interface subroutine psb_ls_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1435,8 +1486,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csgetblk end interface - - interface + + interface subroutine psb_ls_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1448,8 +1499,8 @@ module psb_s_mat_mod class(psb_lsspmat_type), optional, intent(inout) :: u end subroutine psb_ls_tril end interface - - interface + + interface subroutine psb_ls_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1463,7 +1514,7 @@ module psb_s_mat_mod end interface - interface + interface subroutine psb_ls_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1475,7 +1526,7 @@ module psb_s_mat_mod end subroutine psb_ls_csclip end interface - interface + interface subroutine psb_ls_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1485,8 +1536,8 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_csclip_ip end interface - - interface + + interface subroutine psb_ls_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_coo_sparse_mat @@ -1497,60 +1548,60 @@ module psb_s_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_ls_b_csclip end interface - - interface + + interface subroutine psb_ls_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_ls_mold end interface - - interface - subroutine psb_ls_asb(a,mold) + + interface + subroutine psb_ls_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_ls_asb end interface - - interface + + interface subroutine psb_ls_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_transp_1mat end interface - - interface + + interface subroutine psb_ls_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: b end subroutine psb_ls_transp_2mat end interface - - interface + + interface subroutine psb_ls_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a end subroutine psb_ls_transc_1mat end interface - - interface + + interface subroutine psb_ls_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: b end subroutine psb_ls_transc_2mat end interface - - interface + + interface subroutine psb_ls_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type - class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_ls_reinit - + end interface @@ -1565,9 +1616,9 @@ module psb_s_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(in) :: a @@ -1578,9 +1629,9 @@ module psb_s_mat_mod class(psb_ls_base_sparse_mat), intent(in), optional :: mold end subroutine psb_ls_cscnv end interface - - interface + + interface subroutine psb_ls_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a @@ -1590,9 +1641,9 @@ module psb_s_mat_mod class(psb_ls_base_sparse_mat), intent(in), optional :: mold end subroutine psb_ls_cscnv_ip end interface - - interface + + interface subroutine psb_ls_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(in) :: a @@ -1601,13 +1652,13 @@ module psb_s_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_ls_cscnv_base end interface - - + + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_ls_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(in) :: a @@ -1615,47 +1666,47 @@ module psb_s_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_ls_clip_d end interface - - interface + + interface subroutine psb_ls_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_ls_clip_d_ip end interface - - + + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_ls_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_mv_from end interface - - interface + + interface subroutine psb_ls_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(out) :: a class(psb_ls_base_sparse_mat), intent(in) :: b end subroutine psb_ls_cp_from end interface - - interface + + interface subroutine psb_ls_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_mv_to end interface - - interface + + interface subroutine psb_ls_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat class(psb_lsspmat_type), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_cp_to @@ -1663,63 +1714,63 @@ module psb_s_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_ls_mv_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_mv_from_ib end interface - - interface + + interface subroutine psb_ls_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_lsspmat_type), intent(out) :: a class(psb_s_base_sparse_mat), intent(in) :: b end subroutine psb_ls_cp_from_ib end interface - - interface + + interface subroutine psb_ls_mv_to_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_lsspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_mv_to_ib end interface - - interface + + interface subroutine psb_ls_cp_to_ib(a,b) - import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat class(psb_lsspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b end subroutine psb_ls_cp_to_ib end interface - interface + interface subroutine psb_ls_mv_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type class(psb_lsspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b end subroutine psb_ls_mv_from_i end interface - - interface + + interface subroutine psb_ls_cp_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type class(psb_lsspmat_type), intent(out) :: a class(psb_sspmat_type), intent(in) :: b end subroutine psb_ls_cp_from_i end interface - - interface + + interface subroutine psb_ls_mv_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type class(psb_lsspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b end subroutine psb_ls_mv_to_i end interface - - interface + + interface subroutine psb_ls_cp_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type class(psb_lsspmat_type), intent(in) :: a @@ -1727,11 +1778,11 @@ module psb_s_mat_mod end subroutine psb_ls_cp_to_i end interface - + ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_lsspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a @@ -1739,8 +1790,8 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lsspmat_type_move end interface - - interface + + interface subroutine psb_lsspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type class(psb_lsspmat_type), intent(inout) :: a @@ -1751,7 +1802,7 @@ module psb_s_mat_mod - interface + interface function psb_ls_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a @@ -1759,7 +1810,7 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_ls_get_diag end interface - + interface psb_scal subroutine psb_ls_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ @@ -1776,23 +1827,43 @@ module psb_s_mat_mod end subroutine psb_ls_scals end interface - interface + interface psb_scalplusidentity + subroutine psb_ls_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_ls_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_spaxpby + end interface + + interface function psb_ls_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_ls_maxval end interface - - interface + + interface function psb_ls_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a real(psb_spk_) :: res end function psb_ls_csnmi end interface - - interface + + interface function psb_ls_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a @@ -1800,7 +1871,7 @@ module psb_s_mat_mod end function psb_ls_csnm1 end interface - interface + interface function psb_ls_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a @@ -1809,7 +1880,7 @@ module psb_s_mat_mod end function psb_ls_rowsum end interface - interface + interface function psb_ls_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a @@ -1817,8 +1888,8 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_ls_arwsum end interface - - interface + + interface function psb_ls_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a @@ -1827,7 +1898,7 @@ module psb_s_mat_mod end function psb_ls_colsum end interface - interface + interface function psb_ls_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ class(psb_lsspmat_type), intent(in) :: a @@ -1835,40 +1906,59 @@ module psb_s_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_ls_aclsum end interface - -contains - subroutine psb_s_set_mat_default(a) - implicit none + interface psb_cmpmat + function psb_ls_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ls_cmpval + function psb_ls_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_ls_cmpmat + end interface + +contains + + subroutine psb_s_set_mat_default(a) + implicit none class(psb_s_base_sparse_mat), intent(in) :: a - - if (allocated(psb_s_base_mat_default)) then + + if (allocated(psb_s_base_mat_default)) then deallocate(psb_s_base_mat_default) end if allocate(psb_s_base_mat_default, mold=a) end subroutine psb_s_set_mat_default - + function psb_s_get_mat_default(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), pointer :: res - + res => psb_s_get_base_mat_default() - + end function psb_s_get_mat_default - + function psb_s_get_base_mat_default() result(res) - implicit none + implicit none class(psb_s_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_s_base_mat_default)) then + + if (.not.allocated(psb_s_base_mat_default)) then allocate(psb_s_csr_sparse_mat :: psb_s_base_mat_default) end if res => psb_s_base_mat_default - + end function psb_s_get_base_mat_default subroutine psb_s_clear_mat_default() @@ -1886,7 +1976,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1894,26 +1984,26 @@ contains ! ! == =================================== - + function psb_s_sizeof(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_s_sizeof function psb_s_get_fmt(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -1923,11 +2013,11 @@ contains function psb_s_get_dupl(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -1935,11 +2025,11 @@ contains end function psb_s_get_dupl function psb_s_get_nrows(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -1948,11 +2038,11 @@ contains end function psb_s_get_nrows function psb_s_get_ncols(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -1961,11 +2051,11 @@ contains end function psb_s_get_ncols function psb_s_is_triangle(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -1974,11 +2064,11 @@ contains end function psb_s_is_triangle function psb_s_is_symmetric(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -1987,11 +2077,11 @@ contains end function psb_s_is_symmetric function psb_s_is_unit(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2000,11 +2090,11 @@ contains end function psb_s_is_unit function psb_s_is_upper(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2013,11 +2103,11 @@ contains end function psb_s_is_upper function psb_s_is_lower(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2026,12 +2116,12 @@ contains end function psb_s_is_lower function psb_s_is_null(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2039,11 +2129,11 @@ contains end function psb_s_is_null function psb_s_is_bld(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2052,11 +2142,11 @@ contains end function psb_s_is_bld function psb_s_is_upd(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2065,11 +2155,11 @@ contains end function psb_s_is_upd function psb_s_is_asb(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2078,11 +2168,11 @@ contains end function psb_s_is_asb function psb_s_is_sorted(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2091,11 +2181,11 @@ contains end function psb_s_is_sorted function psb_s_is_by_rows(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2104,11 +2194,11 @@ contains end function psb_s_is_by_rows function psb_s_is_by_cols(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2119,61 +2209,61 @@ contains ! subroutine s_mat_sync(a) - implicit none + implicit none class(psb_sspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine s_mat_sync ! subroutine s_mat_set_host(a) - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine s_mat_set_host ! subroutine s_mat_set_dev(a) - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine s_mat_set_dev ! subroutine s_mat_set_sync(a) - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine s_mat_set_sync ! function s_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function s_mat_is_dev - + ! function s_mat_is_host(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2183,11 +2273,11 @@ contains ! function s_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2198,11 +2288,11 @@ contains function psb_s_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2210,25 +2300,25 @@ contains end function psb_s_is_repeatable_updates - subroutine psb_s_set_repeatable_updates(a,val) - implicit none + subroutine psb_s_set_repeatable_updates(a,val) + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_s_set_repeatable_updates function psb_s_get_nzeros(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2236,13 +2326,13 @@ contains function psb_s_get_size(a) result(res) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2250,23 +2340,23 @@ contains function psb_s_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_ipk_), intent(in) :: idx class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_s_get_nz_row subroutine psb_s_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_sspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_s_clean_zeros @@ -2274,7 +2364,7 @@ contains #if defined(IPK4) && defined(LPK8) subroutine psb_s_lcsgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2303,17 +2393,17 @@ contains end if call a%csget(imin,imax,nz,lia,lja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_s_lcsgetptn - + subroutine psb_s_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2342,12 +2432,12 @@ contains call a%csget(imin,imax,nz,lia,lja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_s_lcsgetrow #endif @@ -2355,38 +2445,38 @@ contains ! ls methods ! - - subroutine psb_ls_set_mat_default(a) - implicit none + + subroutine psb_ls_set_mat_default(a) + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a - - if (allocated(psb_ls_base_mat_default)) then + + if (allocated(psb_ls_base_mat_default)) then deallocate(psb_ls_base_mat_default) end if allocate(psb_ls_base_mat_default, mold=a) end subroutine psb_ls_set_mat_default - + function psb_ls_get_mat_default(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_ls_base_sparse_mat), pointer :: res - + res => psb_ls_get_base_mat_default() - + end function psb_ls_get_mat_default - + function psb_ls_get_base_mat_default() result(res) - implicit none + implicit none class(psb_ls_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_ls_base_mat_default)) then + + if (.not.allocated(psb_ls_base_mat_default)) then allocate(psb_ls_csr_sparse_mat :: psb_ls_base_mat_default) end if res => psb_ls_base_mat_default - + end function psb_ls_get_base_mat_default subroutine psb_ls_clear_mat_default() @@ -2404,7 +2494,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -2412,26 +2502,26 @@ contains ! ! == =================================== - + function psb_ls_sizeof(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_ls_sizeof function psb_ls_get_fmt(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -2441,11 +2531,11 @@ contains function psb_ls_get_dupl(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -2453,11 +2543,11 @@ contains end function psb_ls_get_dupl function psb_ls_get_nrows(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -2466,11 +2556,11 @@ contains end function psb_ls_get_nrows function psb_ls_get_ncols(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -2479,11 +2569,11 @@ contains end function psb_ls_get_ncols function psb_ls_is_triangle(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -2493,11 +2583,11 @@ contains function psb_ls_is_symmetric(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -2506,11 +2596,11 @@ contains end function psb_ls_is_symmetric function psb_ls_is_unit(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2519,11 +2609,11 @@ contains end function psb_ls_is_unit function psb_ls_is_upper(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2532,11 +2622,11 @@ contains end function psb_ls_is_upper function psb_ls_is_lower(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2545,12 +2635,12 @@ contains end function psb_ls_is_lower function psb_ls_is_null(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2558,11 +2648,11 @@ contains end function psb_ls_is_null function psb_ls_is_bld(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2571,11 +2661,11 @@ contains end function psb_ls_is_bld function psb_ls_is_upd(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2584,11 +2674,11 @@ contains end function psb_ls_is_upd function psb_ls_is_asb(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2597,11 +2687,11 @@ contains end function psb_ls_is_asb function psb_ls_is_sorted(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2610,11 +2700,11 @@ contains end function psb_ls_is_sorted function psb_ls_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2623,11 +2713,11 @@ contains end function psb_ls_is_by_rows function psb_ls_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2638,61 +2728,61 @@ contains ! subroutine ls_mat_sync(a) - implicit none + implicit none class(psb_lsspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine ls_mat_sync ! subroutine ls_mat_set_host(a) - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine ls_mat_set_host ! subroutine ls_mat_set_dev(a) - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine ls_mat_set_dev ! subroutine ls_mat_set_sync(a) - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine ls_mat_set_sync ! function ls_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function ls_mat_is_dev - + ! function ls_mat_is_host(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2702,11 +2792,11 @@ contains ! function ls_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2717,11 +2807,11 @@ contains function psb_ls_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2729,25 +2819,25 @@ contains end function psb_ls_is_repeatable_updates - subroutine psb_ls_set_repeatable_updates(a,val) - implicit none + subroutine psb_ls_set_repeatable_updates(a,val) + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_ls_set_repeatable_updates function psb_ls_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2755,13 +2845,13 @@ contains function psb_ls_get_size(a) result(res) - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2769,23 +2859,23 @@ contains function psb_ls_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_lpk_), intent(in) :: idx class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_ls_get_nz_row subroutine psb_ls_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_lsspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_ls_clean_zeros @@ -2793,7 +2883,7 @@ contains #if defined(IPK4) && defined(LPK8) !!$ subroutine psb_ls_icsgetptn(imin,imax,a,nz,ia,ja,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_lsspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2829,12 +2919,12 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_ls_icsgetptn -!!$ +!!$ !!$ subroutine psb_ls_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_lsspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2870,7 +2960,7 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_ls_icsgetrow #endif diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index d47e6f2a9..1b9d212d2 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_s_vect_mod ! ! This module contains the definition of the psb_s_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_s_vect_mod @@ -43,7 +43,7 @@ module psb_s_vect_mod use psb_i_vect_mod type psb_s_vect_type - class(psb_s_base_vect_type), allocatable :: v + class(psb_s_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => s_vect_get_nrows procedure, pass(x) :: sizeof => s_vect_sizeof @@ -85,7 +85,9 @@ module psb_s_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => s_vect_axpby_v procedure, pass(y) :: axpby_a => s_vect_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => s_vect_axpby_v2 + procedure, pass(z) :: axpby_a2 => s_vect_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 procedure, pass(y) :: mlt_v => s_vect_mlt_v procedure, pass(y) :: mlt_a => s_vect_mlt_a procedure, pass(z) :: mlt_a_2 => s_vect_mlt_a_2 @@ -94,13 +96,44 @@ module psb_s_vect_mod procedure, pass(z) :: mlt_av => s_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => s_vect_div_v + procedure, pass(z) :: div_v2 => s_vect_div_v2 + procedure, pass(x) :: div_v_check => s_vect_div_v_check + procedure, pass(x) :: div_v2_check => s_vect_div_v2_check + procedure, pass(z) :: div_a2 => s_vect_div_a2 + procedure, pass(z) :: div_a2_check => s_vect_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => s_vect_inv_v + procedure, pass(y) :: inv_v_check => s_vect_inv_v_check + procedure, pass(y) :: inv_a2 => s_vect_inv_a2 + procedure, pass(y) :: inv_a2_check => s_vect_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check procedure, pass(x) :: scal => s_vect_scal procedure, pass(x) :: absval1 => s_vect_absval1 procedure, pass(x) :: absval2 => s_vect_absval2 generic, public :: absval => absval1, absval2 - procedure, pass(x) :: nrm2 => s_vect_nrm2 + procedure, pass(x) :: nrm2std => s_vect_nrm2 + procedure, pass(x) :: nrm2weight => s_vect_nrm2_weight + procedure, pass(x) :: nrm2weightmask => s_vect_nrm2_weight_mask + generic, public :: nrm2 => nrm2std, nrm2weight, nrm2weightmask procedure, pass(x) :: amax => s_vect_amax - procedure, pass(x) :: asum => s_vect_asum + procedure, pass(x) :: asum => s_vect_asum + procedure, pass(z) :: acmp_a2 => s_vect_acmp_a2 + procedure, pass(z) :: acmp_v2 => s_vect_acmp_v2 + generic, public :: acmp => acmp_a2, acmp_v2 + procedure, pass(z) :: addconst_a2 => s_vect_addconst_a2 + procedure, pass(z) :: addconst_v2 => s_vect_addconst_v2 + generic, public :: addconst => addconst_a2, addconst_v2 + + procedure, pass(x) :: minreal => s_vect_min + procedure, pass(m) :: mask_v => s_vect_mask_v + procedure, pass(m) :: mask_a => s_vect_mask_a + generic, public :: mask => mask_a, mask_v + procedure, pass(x) :: minquotient_v => s_vect_minquotient_v + procedure, pass(x) :: minquotient_a2 => s_vect_minquotient_a2 + generic, public :: minquotient => minquotient_v, minquotient_a2 + end type psb_s_vect_type public :: psb_s_vect @@ -122,8 +155,7 @@ module psb_s_vect_mod private :: s_vect_dot_v, s_vect_dot_a, s_vect_axpby_v, s_vect_axpby_a, & & s_vect_mlt_v, s_vect_mlt_a, s_vect_mlt_a_2, s_vect_mlt_v_2, & & s_vect_mlt_va, s_vect_mlt_av, s_vect_scal, s_vect_absval1, & - & s_vect_absval2, s_vect_nrm2, s_vect_amax, s_vect_asum - + & s_vect_absval2, s_vect_nrm2, s_vect_amax, s_vect_asum class(psb_s_base_vect_type), allocatable, target,& @@ -141,11 +173,11 @@ module psb_s_vect_mod contains - subroutine psb_s_set_vect_default(v) - implicit none + subroutine psb_s_set_vect_default(v) + implicit none class(psb_s_base_vect_type), intent(in) :: v - if (allocated(psb_s_base_vect_default)) then + if (allocated(psb_s_base_vect_default)) then deallocate(psb_s_base_vect_default) end if allocate(psb_s_base_vect_default, mold=v) @@ -153,7 +185,7 @@ contains end subroutine psb_s_set_vect_default function psb_s_get_vect_default(v) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: v class(psb_s_base_vect_type), pointer :: res @@ -171,10 +203,10 @@ contains end subroutine psb_s_clear_vect_default function psb_s_get_base_vect_default() result(res) - implicit none + implicit none class(psb_s_base_vect_type), pointer :: res - if (.not.allocated(psb_s_base_vect_default)) then + if (.not.allocated(psb_s_base_vect_default)) then allocate(psb_s_base_vect_type :: psb_s_base_vect_default) end if @@ -183,14 +215,14 @@ contains end function psb_s_get_base_vect_default subroutine s_vect_clone(x,y,info) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine s_vect_clone @@ -205,7 +237,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) @@ -227,7 +259,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) @@ -247,7 +279,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) @@ -310,7 +342,7 @@ contains end function size_const function s_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -318,7 +350,7 @@ contains end function s_vect_get_nrows function s_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -326,7 +358,7 @@ contains end function s_vect_sizeof function s_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -335,7 +367,7 @@ contains subroutine s_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold @@ -344,12 +376,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_s_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -359,12 +391,12 @@ contains subroutine s_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -374,7 +406,7 @@ contains subroutine s_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -384,7 +416,7 @@ contains subroutine s_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -430,12 +462,12 @@ contains subroutine s_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -444,7 +476,7 @@ contains subroutine s_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -454,7 +486,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -465,7 +497,7 @@ contains subroutine s_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -475,7 +507,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -493,12 +525,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_s_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -509,7 +541,7 @@ contains subroutine s_vect_sync(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -518,7 +550,7 @@ contains end subroutine s_vect_sync subroutine s_vect_set_sync(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -527,7 +559,7 @@ contains end subroutine s_vect_set_sync subroutine s_vect_set_host(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -536,7 +568,7 @@ contains end subroutine s_vect_set_host subroutine s_vect_set_dev(x) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -545,7 +577,7 @@ contains end subroutine s_vect_set_dev function s_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x @@ -556,7 +588,7 @@ contains end function s_vect_is_sync function s_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x @@ -567,11 +599,11 @@ contains end function s_vect_is_host function s_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_s_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -579,7 +611,7 @@ contains function s_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res @@ -591,7 +623,7 @@ contains end function s_vect_dot_v function s_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -605,14 +637,14 @@ contains subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y real(psb_spk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -620,9 +652,27 @@ contains end subroutine s_vect_axpby_v + subroutine s_vect_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine s_vect_axpby_v2 + subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent(in) :: x(:) class(psb_s_vect_type), intent(inout) :: y @@ -634,13 +684,27 @@ contains end subroutine s_vect_axpby_a + subroutine s_vect_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine s_vect_axpby_a2 subroutine s_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -651,7 +715,7 @@ contains subroutine s_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: x(:) class(psb_s_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -667,7 +731,7 @@ contains subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) real(psb_spk_), intent(in) :: x(:) @@ -675,7 +739,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -683,12 +747,12 @@ contains subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -702,12 +766,12 @@ contains subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: x(:) class(psb_s_vect_type), intent(inout) :: y class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -718,12 +782,12 @@ contains subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none real(psb_spk_), intent(in) :: alpha,beta real(psb_spk_), intent(in) :: y(:) class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -733,9 +797,186 @@ contains end subroutine s_vect_mlt_va + subroutine s_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine s_vect_div_v + + subroutine s_vect_div_v2( x, y, z, info) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine s_vect_div_v2 + + subroutine s_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine s_vect_div_v_check + + subroutine s_vect_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine s_vect_div_v2_check + + subroutine s_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine s_vect_div_a2 + + subroutine s_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine s_vect_div_a2_check + + subroutine s_vect_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine s_vect_inv_v + + subroutine s_vect_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine s_vect_inv_v_check + + subroutine s_vect_inv_a2(x, y, info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine s_vect_inv_a2 + + subroutine s_vect_inv_a2_check(x, y, info,flag) + use psi_serial_mod + implicit none + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine s_vect_inv_a2_check + + subroutine s_vect_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine s_vect_acmp_a2 + + subroutine s_vect_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine s_vect_acmp_v2 + subroutine s_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x real(psb_spk_), intent (in) :: alpha @@ -755,19 +996,19 @@ contains class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine s_vect_absval2 function s_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = szero @@ -775,13 +1016,49 @@ contains end function s_vect_nrm2 + function s_vect_nrm2_weight(n,x,w) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: w + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v)) then + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = szero + end if + + end function s_vect_nrm2_weight + + function s_vect_nrm2_weight_mask(n,x,w,id) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: w + class(psb_s_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v).and.allocated(id%v)) then + where( abs(id%v%v) <= szero) x%v%v = szero + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = szero + end if + + end function s_vect_nrm2_weight_mask + function s_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = szero @@ -789,13 +1066,27 @@ contains end function s_vect_amax - function s_vect_asum(n,x) result(res) - implicit none + function s_vect_min(n,x) result(res) + implicit none class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_spk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then + res = x%v%minreal(n) + else + res = szero + end if + + end function s_vect_min + + function s_vect_asum(n,x) result(res) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + real(psb_spk_) :: res + + if (allocated(x%v)) then res = x%v%asum(n) else res = szero @@ -804,6 +1095,94 @@ contains end function s_vect_asum + subroutine s_vect_mask_a(c,x,m,t,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(inout) :: c(:) + real(psb_spk_), intent(inout) :: x(:) + logical, intent(out) :: t; + class(psb_s_vect_type), intent(inout) :: m + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(m%v)) & + & call m%mask(c,x,t,info) + + end subroutine s_vect_mask_a + + subroutine s_vect_mask_v(c,x,m,t,info) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: c + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: m + logical, intent(out) :: t; + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(c%v)) & + & call m%v%mask(x%v,c%v,t,info) + + end subroutine s_vect_mask_v + + function s_vect_minquotient_v(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: y + real(psb_spk_) :: z + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & z = x%v%minquotient(y%v,info) + + end function s_vect_minquotient_v + + function s_vect_minquotient_a2(x, y, info) result(z) + use psi_serial_mod + implicit none + class(psb_s_vect_type), intent(inout) :: x + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: z + + info = 0 + z = x%v%minquotient(y,info) + + end function s_vect_minquotient_a2 + + + + subroutine s_vect_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: b + real(psb_spk_), intent(inout) :: x(:) + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine s_vect_addconst_a2 + + subroutine s_vect_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_spk_), intent(in) :: b + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine s_vect_addconst_v2 + end module psb_s_vect_mod @@ -818,7 +1197,7 @@ module psb_s_multivect_mod !private type psb_s_multivect_type - class(psb_s_base_multivect_type), allocatable :: v + class(psb_s_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => s_vect_get_nrows procedure, pass(x) :: get_ncols => s_vect_get_ncols @@ -892,11 +1271,11 @@ module psb_s_multivect_mod contains - subroutine psb_s_set_multivect_default(v) - implicit none + subroutine psb_s_set_multivect_default(v) + implicit none class(psb_s_base_multivect_type), intent(in) :: v - if (allocated(psb_s_base_multivect_default)) then + if (allocated(psb_s_base_multivect_default)) then deallocate(psb_s_base_multivect_default) end if allocate(psb_s_base_multivect_default, mold=v) @@ -904,7 +1283,7 @@ contains end subroutine psb_s_set_multivect_default function psb_s_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: v class(psb_s_base_multivect_type), pointer :: res @@ -914,10 +1293,10 @@ contains function psb_s_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_s_base_multivect_type), pointer :: res - if (.not.allocated(psb_s_base_multivect_default)) then + if (.not.allocated(psb_s_base_multivect_default)) then allocate(psb_s_base_multivect_type :: psb_s_base_multivect_default) end if @@ -927,14 +1306,14 @@ contains subroutine s_vect_clone(x,y,info) - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x class(psb_s_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine s_vect_clone @@ -947,7 +1326,7 @@ contains class(psb_s_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) @@ -965,7 +1344,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) @@ -1025,7 +1404,7 @@ contains end function size_const function s_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1033,7 +1412,7 @@ contains end function s_vect_get_nrows function s_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1041,7 +1420,7 @@ contains end function s_vect_get_ncols function s_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1049,7 +1428,7 @@ contains end function s_vect_sizeof function s_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_s_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1058,18 +1437,18 @@ contains subroutine s_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(out) :: x class(psb_s_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_s_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1079,12 +1458,12 @@ contains subroutine s_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1094,7 +1473,7 @@ contains subroutine s_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1104,7 +1483,7 @@ contains subroutine s_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1115,7 +1494,7 @@ contains end subroutine s_vect_asb subroutine s_vect_sync(x) - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1183,12 +1562,12 @@ contains subroutine s_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1197,7 +1576,7 @@ contains subroutine s_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_s_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1207,7 +1586,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1223,12 +1602,12 @@ contains class(psb_s_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_s_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1238,7 +1617,7 @@ contains !!$ function s_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res @@ -1250,28 +1629,28 @@ contains !!$ end function s_vect_dot_v !!$ !!$ function s_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ real(psb_spk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res -!!$ +!!$ !!$ res = szero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function s_vect_dot_a -!!$ +!!$ !!$ subroutine s_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ real(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1281,25 +1660,25 @@ contains !!$ !!$ subroutine s_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ real(psb_spk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine s_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine s_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1310,7 +1689,7 @@ contains !!$ !!$ subroutine s_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1320,13 +1699,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine s_vect_mlt_a !!$ !!$ !!$ subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: y(:) !!$ real(psb_spk_), intent(in) :: x(:) @@ -1334,20 +1713,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine s_vect_mlt_a_2 !!$ !!$ subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ class(psb_s_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1361,12 +1740,12 @@ contains !!$ !!$ subroutine s_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: x(:) !!$ class(psb_s_multivect_type), intent(inout) :: y !!$ class(psb_s_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1377,16 +1756,16 @@ contains !!$ !!$ subroutine s_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ real(psb_spk_), intent(in) :: alpha,beta !!$ real(psb_spk_), intent(in) :: y(:) !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ class(psb_s_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1394,36 +1773,36 @@ contains !!$ !!$ subroutine s_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ real(psb_spk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine s_vect_scal !!$ !!$ !!$ function s_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = szero !!$ end if !!$ !!$ end function s_vect_nrm2 -!!$ +!!$ !!$ function s_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = szero @@ -1432,12 +1811,12 @@ contains !!$ end function s_vect_amax !!$ !!$ function s_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_s_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_spk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = szero diff --git a/base/modules/serial/psb_z_base_mat_mod.F90 b/base/modules/serial/psb_z_base_mat_mod.F90 index 4e9ce7eba..88ba36ec3 100644 --- a/base/modules/serial/psb_z_base_mat_mod.F90 +++ b/base/modules/serial/psb_z_base_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,12 +27,12 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! module psb_z_base_mat_mod - + use psb_base_mat_mod use psb_z_base_vect_mod @@ -56,59 +56,59 @@ module psb_z_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_z_base_csput_a - procedure, pass(a) :: csput_v => psb_z_base_csput_v + procedure, pass(a) :: csput_v => psb_z_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_z_base_csgetrow procedure, pass(a) :: csgetblk => psb_z_base_csgetblk procedure, pass(a) :: get_diag => psb_z_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_z_base_tril procedure, pass(a) :: triu => psb_z_base_triu - procedure, pass(a) :: csclip => psb_z_base_csclip - procedure, pass(a) :: cp_to_coo => psb_z_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_z_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_z_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_z_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_z_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_z_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_z_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_z_base_mv_from_fmt - procedure, pass(a) :: mold => psb_z_base_mold + procedure, pass(a) :: csclip => psb_z_base_csclip + procedure, pass(a) :: cp_to_coo => psb_z_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_z_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_z_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_z_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_z_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_z_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_z_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_z_base_mv_from_fmt + procedure, pass(a) :: mold => psb_z_base_mold procedure, pass(a) :: clone => psb_z_base_clone procedure, pass(a) :: make_nonunit => psb_z_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_z_base_clean_zeros ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_z_base_cp_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_z_base_cp_from_lcoo - procedure, pass(a) :: cp_to_lfmt => psb_z_base_cp_to_lfmt - procedure, pass(a) :: cp_from_lfmt => psb_z_base_cp_from_lfmt - procedure, pass(a) :: mv_to_lcoo => psb_z_base_mv_to_lcoo - procedure, pass(a) :: mv_from_lcoo => psb_z_base_mv_from_lcoo - procedure, pass(a) :: mv_to_lfmt => psb_z_base_mv_to_lfmt - procedure, pass(a) :: mv_from_lfmt => psb_z_base_mv_from_lfmt + procedure, pass(a) :: cp_to_lcoo => psb_z_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_z_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_z_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_z_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_z_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_z_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_z_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_z_base_mv_from_lfmt + - ! - ! Transpose methods: defined here but not implemented. - ! + ! Transpose methods: defined here but not implemented. + ! procedure, pass(a) :: transp_1mat => psb_z_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_z_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_z_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_z_base_transc_2mat - + + ! + ! Computational methods: defined here but not implemented. ! - ! Computational methods: defined here but not implemented. - ! procedure, pass(a) :: vect_mv => psb_z_base_vect_mv procedure, pass(a) :: csmv => psb_z_base_csmv procedure, pass(a) :: csmm => psb_z_base_csmm generic, public :: spmm => csmm, csmv, vect_mv procedure, pass(a) :: in_vect_sv => psb_z_base_inner_vect_sv - procedure, pass(a) :: inner_cssv => psb_z_base_inner_cssv + procedure, pass(a) :: inner_cssv => psb_z_base_inner_cssv procedure, pass(a) :: inner_cssm => psb_z_base_inner_cssm generic, public :: inner_spsm => inner_cssm, inner_cssv, in_vect_sv procedure, pass(a) :: vect_cssv => psb_z_base_vect_cssv @@ -125,15 +125,20 @@ module psb_z_base_mat_mod procedure, pass(a) :: arwsum => psb_z_base_arwsum procedure, pass(a) :: colsum => psb_z_base_colsum procedure, pass(a) :: aclsum => psb_z_base_aclsum + procedure, pass(a) :: scalpid => psb_z_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_z_base_spaxpby + procedure, pass(a) :: cmpval => psb_z_base_cmpval + procedure, pass(a) :: cmpmat => psb_z_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_z_base_sparse_mat - + private :: z_base_mat_sync, z_base_mat_is_host, z_base_mat_is_dev, & & z_base_mat_is_sync, z_base_mat_set_host, z_base_mat_set_dev,& & z_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_z_coo_sparse_mat !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat - !! + !! !! psb_z_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -147,15 +152,15 @@ module psb_z_base_mat_mod integer(psb_ipk_), allocatable :: ia(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => z_coo_get_size procedure, pass(a) :: get_nzeros => z_coo_get_nzeros procedure, nopass :: get_fmt => z_coo_get_fmt @@ -175,9 +180,9 @@ module psb_z_base_mat_mod ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_lcoo => psb_z_cp_coo_to_lcoo - procedure, pass(a) :: cp_from_lcoo => psb_z_cp_coo_from_lcoo - + procedure, pass(a) :: cp_to_lcoo => psb_z_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_z_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_z_coo_csput_a procedure, pass(a) :: get_diag => psb_z_coo_get_diag procedure, pass(a) :: csgetrow => psb_z_coo_csgetrow @@ -203,18 +208,18 @@ module psb_z_base_mat_mod ! This is COO specific ! procedure, pass(a) :: set_nzeros => z_coo_set_nzeros - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => z_coo_transp_1mat procedure, pass(a) :: transc_1mat => z_coo_transc_1mat ! - ! Computational methods. - ! + ! Computational methods. + ! procedure, pass(a) :: csmm => psb_z_coo_csmm procedure, pass(a) :: csmv => psb_z_coo_csmv procedure, pass(a) :: inner_cssm => psb_z_coo_cssm @@ -228,14 +233,17 @@ module psb_z_base_mat_mod procedure, pass(a) :: arwsum => psb_z_coo_arwsum procedure, pass(a) :: colsum => psb_z_coo_colsum procedure, pass(a) :: aclsum => psb_z_coo_aclsum - + procedure, pass(a) :: scalpid => psb_z_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_z_coo_spaxpby + procedure, pass(a) :: cmpval => psb_z_coo_cmpval + procedure, pass(a) :: cmpmat => psb_z_coo_cmpmat end type psb_z_coo_sparse_mat - + private :: z_coo_get_nzeros, z_coo_set_nzeros, & & z_coo_get_fmt, z_coo_free, z_coo_sizeof, & & z_coo_transp_1mat, z_coo_transc_1mat - - + + !> \namespace psb_base_mod \class psb_lz_base_sparse_mat !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat !! The psb_lz_base_sparse_mat type, extending psb_base_sparse_mat, @@ -255,33 +263,33 @@ module psb_z_base_mat_mod contains ! ! Data management methods: defined here, but (mostly) not implemented. - ! + ! procedure, pass(a) :: csput_a => psb_lz_base_csput_a - procedure, pass(a) :: csput_v => psb_lz_base_csput_v + procedure, pass(a) :: csput_v => psb_lz_base_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetrow => psb_lz_base_csgetrow procedure, pass(a) :: csgetblk => psb_lz_base_csgetblk procedure, pass(a) :: get_diag => psb_lz_base_get_diag - generic, public :: csget => csgetrow, csgetblk + generic, public :: csget => csgetrow, csgetblk procedure, pass(a) :: tril => psb_lz_base_tril procedure, pass(a) :: triu => psb_lz_base_triu - procedure, pass(a) :: csclip => psb_lz_base_csclip - procedure, pass(a) :: cp_to_coo => psb_lz_base_cp_to_coo - procedure, pass(a) :: cp_from_coo => psb_lz_base_cp_from_coo - procedure, pass(a) :: cp_to_fmt => psb_lz_base_cp_to_fmt - procedure, pass(a) :: cp_from_fmt => psb_lz_base_cp_from_fmt - procedure, pass(a) :: mv_to_coo => psb_lz_base_mv_to_coo - procedure, pass(a) :: mv_from_coo => psb_lz_base_mv_from_coo - procedure, pass(a) :: mv_to_fmt => psb_lz_base_mv_to_fmt - procedure, pass(a) :: mv_from_fmt => psb_lz_base_mv_from_fmt - procedure, pass(a) :: mold => psb_lz_base_mold + procedure, pass(a) :: csclip => psb_lz_base_csclip + procedure, pass(a) :: cp_to_coo => psb_lz_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_lz_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lz_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lz_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lz_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_lz_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lz_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lz_base_mv_from_fmt + procedure, pass(a) :: mold => psb_lz_base_mold procedure, pass(a) :: clone => psb_lz_base_clone procedure, pass(a) :: make_nonunit => psb_lz_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_lz_base_clean_zeros ! - ! Computational methods: defined here but not implemented. - ! + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_lz_base_scals procedure, pass(a) :: scalv => psb_lz_base_scal generic, public :: scal => scals, scalv @@ -292,35 +300,40 @@ module psb_z_base_mat_mod procedure, pass(a) :: arwsum => psb_lz_base_arwsum procedure, pass(a) :: colsum => psb_lz_base_colsum procedure, pass(a) :: aclsum => psb_lz_base_aclsum + procedure, pass(a) :: scalpid => psb_lz_base_scalplusidentity + procedure, pass(a) :: spaxpby => psb_lz_base_spaxpby + procedure, pass(a) :: cmpval => psb_lz_base_cmpval + procedure, pass(a) :: cmpmat => psb_lz_base_cmpmat + generic, public :: spcmp => cmpval, cmpmat ! ! Convert internal indices ! - procedure, pass(a) :: cp_to_icoo => psb_lz_base_cp_to_icoo - procedure, pass(a) :: cp_from_icoo => psb_lz_base_cp_from_icoo - procedure, pass(a) :: cp_to_ifmt => psb_lz_base_cp_to_ifmt - procedure, pass(a) :: cp_from_ifmt => psb_lz_base_cp_from_ifmt - procedure, pass(a) :: mv_to_icoo => psb_lz_base_mv_to_icoo - procedure, pass(a) :: mv_from_icoo => psb_lz_base_mv_from_icoo - procedure, pass(a) :: mv_to_ifmt => psb_lz_base_mv_to_ifmt - procedure, pass(a) :: mv_from_ifmt => psb_lz_base_mv_from_ifmt - + procedure, pass(a) :: cp_to_icoo => psb_lz_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_lz_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_lz_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_lz_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_lz_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_lz_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_lz_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_lz_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. ! - ! Transpose methods: defined here but not implemented. - ! procedure, pass(a) :: transp_1mat => psb_lz_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_lz_base_transp_2mat procedure, pass(a) :: transc_1mat => psb_lz_base_transc_1mat procedure, pass(a) :: transc_2mat => psb_lz_base_transc_2mat - + end type psb_lz_base_sparse_mat - + private :: lz_base_mat_sync, lz_base_mat_is_host, lz_base_mat_is_dev, & & lz_base_mat_is_sync, lz_base_mat_set_host, lz_base_mat_set_dev,& & lz_base_mat_set_sync - + !> \namespace psb_base_mod \class psb_lz_coo_sparse_mat !! \extends psb_lz_base_mat_mod::psb_lz_base_sparse_mat - !! + !! !! psb_lz_coo_sparse_mat type and the related methods. This is the !! reference type for all the format transitions, copies and mv unless !! methods are implemented that allow the direct transition from one @@ -334,15 +347,15 @@ module psb_z_base_mat_mod integer(psb_lpk_), allocatable :: ia(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) integer, private :: sort_status=psb_unsorted_ - + contains ! - ! Data management methods. - ! + ! Data management methods. + ! procedure, pass(a) :: get_size => lz_coo_get_size procedure, pass(a) :: get_nzeros => lz_coo_get_nzeros procedure, nopass :: get_fmt => lz_coo_get_fmt @@ -360,7 +373,7 @@ module psb_z_base_mat_mod procedure, pass(a) :: mv_from_fmt => psb_lz_mv_coo_from_fmt procedure, pass(a) :: cp_to_icoo => psb_lz_cp_coo_to_icoo procedure, pass(a) :: cp_from_icoo => psb_lz_cp_coo_from_icoo - + procedure, pass(a) :: csput_a => psb_lz_coo_csput_a procedure, pass(a) :: get_diag => psb_lz_coo_get_diag procedure, pass(a) :: csgetrow => psb_lz_coo_csgetrow @@ -382,9 +395,9 @@ module psb_z_base_mat_mod procedure, pass(a) :: set_sort_status => lz_coo_set_sort_status procedure, pass(a) :: get_sort_status => lz_coo_get_sort_status - - ! Computational methods: defined here but not implemented. - ! + + ! Computational methods: defined here but not implemented. + ! procedure, pass(a) :: scals => psb_lz_coo_scals procedure, pass(a) :: scalv => psb_lz_coo_scal procedure, pass(a) :: maxval => psb_lz_coo_maxval @@ -394,7 +407,10 @@ module psb_z_base_mat_mod procedure, pass(a) :: arwsum => psb_lz_coo_arwsum procedure, pass(a) :: colsum => psb_lz_coo_colsum procedure, pass(a) :: aclsum => psb_lz_coo_aclsum - + procedure, pass(a) :: scalpid => psb_lz_coo_scalplusidentity + procedure, pass(a) :: spaxpby => psb_lz_coo_spaxpby + procedure, pass(a) :: cmpval => psb_lz_coo_cmpval + procedure, pass(a) :: cmpmat => psb_lz_coo_cmpmat ! ! This is COO specific ! @@ -406,25 +422,25 @@ module psb_z_base_mat_mod procedure, pass(a) :: iset_nzeros => lz_coo_iset_nzeros generic, public :: set_nzeros => iset_nzeros #endif - + ! ! Transpose methods. These are the base of all ! indirection in transpose, together with conversions - ! they are sufficient for all cases. + ! they are sufficient for all cases. ! procedure, pass(a) :: transp_1mat => lz_coo_transp_1mat procedure, pass(a) :: transc_1mat => lz_coo_transc_1mat - + end type psb_lz_coo_sparse_mat - + private :: lz_coo_get_nzeros, lz_coo_iset_nzeros, & & lz_coo_get_fmt, lz_coo_free, lz_coo_sizeof, & & lz_coo_transp_1mat, lz_coo_transc_1mat #if defined(IPK4) && defined(LPK8) private :: lz_coo_lset_nzeros #endif - + ! == ================= ! ! BASE interfaces @@ -433,14 +449,14 @@ module psb_z_base_mat_mod !> Function csput: !! \memberof psb_z_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -453,33 +469,33 @@ module psb_z_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_csput_a end interface - - interface - subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -487,43 +503,43 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_z_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_z_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -536,33 +552,33 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_z_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_z_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -573,34 +589,34 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_z_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_z_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -621,27 +637,27 @@ module psb_z_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_z_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -650,13 +666,13 @@ module psb_z_base_mat_mod class(psb_z_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_z_base_tril end interface - + ! !> Function triu: !! \memberof psb_z_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -665,27 +681,27 @@ module psb_z_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_z_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -694,27 +710,27 @@ module psb_z_base_mat_mod class(psb_z_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_z_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_z_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_z_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_z_base_get_diag(a,d,info) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_z_base_sparse_mat @@ -724,10 +740,10 @@ module psb_z_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mold(a,b,info) - import + ! + interface + subroutine psb_z_base_mold(a,b,info) + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -739,21 +755,21 @@ module psb_z_base_mat_mod !> Function clone: !! \memberof psb_z_base_sparse_mat !! \brief Allocate and clone a class(psb_z_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_z_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_clone end interface @@ -763,18 +779,18 @@ module psb_z_base_mat_mod !> Function make_nonunit: !! \memberof psb_z_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_z_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a end subroutine psb_z_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_z_base_sparse_mat @@ -782,16 +798,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_to_coo(a,b,info) + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_z_base_sparse_mat @@ -799,16 +815,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_from_coo(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_z_base_sparse_mat @@ -817,16 +833,16 @@ module psb_z_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_to_fmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_z_base_sparse_mat @@ -835,16 +851,16 @@ module psb_z_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_from_fmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_z_base_sparse_mat @@ -852,16 +868,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_to_coo(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_z_base_sparse_mat @@ -869,16 +885,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_from_coo(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_z_base_sparse_mat @@ -887,16 +903,16 @@ module psb_z_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_to_fmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_z_base_sparse_mat @@ -905,10 +921,10 @@ module psb_z_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_from_fmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -921,16 +937,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_to_lcoo(a,b,info) + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_to_lcoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_z_base_sparse_mat @@ -938,16 +954,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_from_lcoo(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_from_lcoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_z_base_sparse_mat @@ -956,16 +972,16 @@ module psb_z_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_to_lfmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_to_lfmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_z_base_sparse_mat @@ -974,16 +990,16 @@ module psb_z_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_cp_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_z_base_cp_from_lfmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_cp_from_lfmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_z_base_sparse_mat @@ -991,16 +1007,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_to_lcoo(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_to_lcoo(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_to_lcoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_z_base_sparse_mat @@ -1008,16 +1024,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_from_lcoo(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_from_lcoo(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_from_lcoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_z_base_sparse_mat @@ -1026,16 +1042,16 @@ module psb_z_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_to_lfmt(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_to_lfmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_to_lfmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_z_base_sparse_mat @@ -1044,10 +1060,10 @@ module psb_z_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_z_base_mv_from_lfmt(a,b,info) - import + ! + interface + subroutine psb_z_base_mv_from_lfmt(a,b,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1056,78 +1072,78 @@ module psb_z_base_mat_mod ! - !> + !> !! \memberof psb_z_base_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_clean_zeros ! interface subroutine psb_z_base_clean_zeros(a, info) - import + import class(psb_z_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_clean_zeros end interface - + ! !> Function transp: !! \memberof psb_z_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_z_base_transp_2mat(a,b) - import + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_z_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_z_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_z_base_transc_2mat(a,b) - import + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_z_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_z_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_z_base_transp_1mat(a) - import + import class(psb_z_base_sparse_mat), intent(inout) :: a end subroutine psb_z_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_z_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_z_base_transc_1mat(a) - import + import class(psb_z_base_sparse_mat), intent(inout) :: a end subroutine psb_z_base_transc_1mat end interface - + ! !> Function csmm: !! \memberof psb_z_base_sparse_mat @@ -1146,9 +1162,9 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! ! - interface + interface subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) - import + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1156,7 +1172,7 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_base_csmm end interface - + !> Function csmv: !! \memberof psb_z_base_sparse_mat !! \brief Product by a dense rank 1 array. @@ -1174,9 +1190,9 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1184,7 +1200,7 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_base_csmv end interface - + !> Function vect_mv: !! \memberof psb_z_base_sparse_mat !! \brief Product by an encapsulated array type(psb_z_vect_type) @@ -1196,7 +1212,7 @@ module psb_z_base_mat_mod !! versions with the standard arrays. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1209,9 +1225,9 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x @@ -1220,7 +1236,7 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_base_vect_mv end interface - + ! !> Function cssm: !! \memberof psb_z_base_sparse_mat @@ -1229,7 +1245,7 @@ module psb_z_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssm. + !! Internal workhorse called by cssm. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1241,9 +1257,9 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! ! - interface - subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1251,8 +1267,8 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_base_inner_cssm end interface - - + + ! !> Function cssv: !! \memberof psb_z_base_sparse_mat @@ -1261,7 +1277,7 @@ module psb_z_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by cssv. + !! Internal workhorse called by cssv. !! !! \param alpha Scaling factor for Ax !! \param A the input sparse matrix @@ -1273,12 +1289,12 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface - subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1286,7 +1302,7 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_base_inner_cssv end interface - + ! !> Function inner_vect_cssv: !! \memberof psb_z_base_sparse_mat @@ -1296,10 +1312,10 @@ module psb_z_base_mat_mod !! Compute !! Y = alpha*op(A^-1)*X + beta*Y !! - !! Internal workhorse called by vect_cssv. + !! Internal workhorse called by vect_cssv. !! Must be overridden explicitly in case of non standard memory !! management; an example would be external memory allocation - !! in attached processors such as GPUs. + !! in attached processors such as GPUs. !! !! !! \param alpha Scaling factor for Ax @@ -1311,9 +1327,9 @@ module psb_z_base_mat_mod !! \param trans [N] Whether to use A (N), its transpose (T) !! or its conjugate transpose (C) ! - interface - subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x, y @@ -1321,7 +1337,7 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_base_inner_vect_sv end interface - + ! !> Function cssm: !! \memberof psb_z_base_sparse_mat @@ -1340,12 +1356,12 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1354,7 +1370,7 @@ module psb_z_base_mat_mod complex(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_z_base_cssm end interface - + ! !> Function cssv: !! \memberof psb_z_base_sparse_mat @@ -1373,12 +1389,12 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D(:) [none] Diagonal for scaling. + !! \param D(:) [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1387,7 +1403,7 @@ module psb_z_base_mat_mod complex(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_z_base_cssv end interface - + ! !> Function vect_cssv: !! \memberof psb_z_base_sparse_mat @@ -1407,12 +1423,12 @@ module psb_z_base_mat_mod !! or its conjugate transpose (C) !! \param scale [N] Apply a scaling on Right (R) i.e. ADX !! or on the Left (L) i.e. DAx - !! \param D [none] Diagonal for scaling. + !! \param D [none] Diagonal for scaling. !! ! - interface + interface subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x,y @@ -1421,24 +1437,24 @@ module psb_z_base_mat_mod class(psb_z_base_vect_type), optional, intent(inout) :: d end subroutine psb_z_base_vect_cssv end interface - + ! !> Function base_scals: !! \memberof psb_z_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_z_base_scals(d,a,info) - import + interface + subroutine psb_z_base_scals(d,a,info) + import class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_scals end interface - + ! !> Function base_scal: !! \memberof psb_z_base_sparse_mat @@ -1448,40 +1464,125 @@ module psb_z_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_z_base_scal(d,a,info,side) - import + interface + subroutine psb_z_base_scal(d,a,info,side) + import class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_z_base_scal end interface - + + ! + !> Function base_scalplusidentity: + !! \memberof psb_z_base_sparse_mat + !! \brief Scale a matrix by a vector and sums an identity + !! + !! \param d Scaling + !! \param info return code + ! + interface + subroutine psb_z_base_scalplusidentity(d,a,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_scalplusidentity + end interface + + ! + !> Function base_spaxpby: + !! \memberof psb_z_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_z_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_spaxpby + end interface + + ! + !> Function base_cmpval: + !! \memberof psb_z_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_z_base_cmpval(a,val,tol,info) result(res) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_z_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_z_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_z_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_z_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_z_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_z_base_maxval(a) result(res) - import + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_z_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_z_base_csnmi(a) result(res) - import + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_base_csnmi @@ -1492,11 +1593,11 @@ module psb_z_base_mat_mod !> Function base_csnmi: !! \memberof psb_z_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_z_base_csnm1(a) result(res) - import + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_base_csnm1 @@ -1508,11 +1609,11 @@ module psb_z_base_mat_mod !! \memberof psb_z_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_z_base_rowsum(d,a) - import + interface + subroutine psb_z_base_rowsum(d,a) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_rowsum @@ -1523,26 +1624,26 @@ module psb_z_base_mat_mod !! \memberof psb_z_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_z_base_arwsum(d,a) - import + !! + interface + subroutine psb_z_base_arwsum(d,a) + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_z_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_z_base_colsum(d,a) - import + interface + subroutine psb_z_base_colsum(d,a) + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_colsum @@ -1553,16 +1654,16 @@ module psb_z_base_mat_mod !! \memberof psb_z_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_z_base_aclsum(d,a) - import + !! + interface + subroutine psb_z_base_aclsum(d,a) + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_aclsum end interface - + ! == =============== ! ! COO interfaces @@ -1570,76 +1671,76 @@ module psb_z_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_z_coo_reallocate_nz(nz,a) - import + subroutine psb_z_coo_reallocate_nz(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a end subroutine psb_z_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_z_coo_sparse_mat ! interface - subroutine psb_z_coo_ensure_size(nz,a) - import + subroutine psb_z_coo_ensure_size(nz,a) + import integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a end subroutine psb_z_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_z_coo_reinit(a,clear) - import - class(psb_z_coo_sparse_mat), intent(inout) :: a + import + class(psb_z_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_coo_reinit end interface ! - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_z_coo_trim(a) - import + import class(psb_z_coo_sparse_mat), intent(inout) :: a end subroutine psb_z_coo_trim end interface ! - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_clean_zeros ! interface subroutine psb_z_coo_clean_zeros(a,info) - import + import class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_clean_zeros end interface ! - !> + !> !! \memberof psb_z_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_z_coo_clean_negidx(a,info) - import + import class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_clean_negidx @@ -1655,11 +1756,11 @@ module psb_z_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_z_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_z_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) @@ -1668,34 +1769,34 @@ module psb_z_base_mat_mod end subroutine psb_z_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner - + ! - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_ipk_), intent(in) :: m,n class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_z_coo_allocate_mnnz end interface - + !> \memberof psb_z_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_z_coo_mold(a,b,info) - import + interface + subroutine psb_z_coo_mold(a,b,info) + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_z_coo_sparse_mat @@ -1710,17 +1811,17 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_z_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_z_coo_sparse_mat @@ -1729,16 +1830,16 @@ module psb_z_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_z_coo_get_nz_row(idx,a) result(res) - import + import class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res end function psb_z_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -1750,12 +1851,12 @@ module psb_z_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) @@ -1764,162 +1865,162 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_z_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_z_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_z_fix_coo(a,info,idir) - import + interface + subroutine psb_z_fix_coo(a,info,idir) + import class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_z_fix_coo end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo - interface - subroutine psb_z_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_z_cp_coo_to_coo(a,b,info) + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo - interface - subroutine psb_z_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_z_cp_coo_from_coo(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_from_coo end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo - interface - subroutine psb_z_cp_coo_to_lcoo(a,b,info) - import + interface + subroutine psb_z_cp_coo_to_lcoo(a,b,info) + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_to_lcoo end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo - interface - subroutine psb_z_cp_coo_from_lcoo(a,b,info) - import + interface + subroutine psb_z_cp_coo_from_lcoo(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_from_lcoo end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo - !! - interface - subroutine psb_z_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_z_cp_coo_to_fmt(a,b,info) + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_fmt - !! - interface - subroutine psb_z_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_z_cp_coo_from_fmt(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_to_coo - interface - subroutine psb_z_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_z_mv_coo_to_coo(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo - interface - subroutine psb_z_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_z_mv_coo_from_coo(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_to_fmt - interface - subroutine psb_z_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_z_mv_coo_to_fmt(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt - interface - subroutine psb_z_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_z_mv_coo_from_fmt(a,b,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_z_coo_cp_from(a,b) - import + import class(psb_z_coo_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat), intent(in) :: b end subroutine psb_z_coo_cp_from end interface - - interface + + interface subroutine psb_z_coo_mv_from(a,b) - import + import class(psb_z_coo_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat), intent(inout) :: b end subroutine psb_z_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_z_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -1936,9 +2037,9 @@ module psb_z_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1946,14 +2047,14 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_csput_a end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1965,14 +2066,14 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_coo_csgetptn end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csgetrow - interface + interface subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import + import class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1985,13 +2086,13 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_coo_csgetrow end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssv - interface - subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1999,12 +2100,12 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_coo_cssv end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssm - interface - subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -2012,13 +2113,13 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_coo_cssm end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csmv - interface - subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -2027,12 +2128,12 @@ module psb_z_base_mat_mod end subroutine psb_z_coo_csmv end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csmm - interface - subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) - import + interface + subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -2040,121 +2141,173 @@ module psb_z_base_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_coo_csmm end interface - - - !> + + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_maxval - interface + interface function psb_z_coo_maxval(a) result(res) - import + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_coo_maxval end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csnmi - interface + interface function psb_z_coo_csnmi(a) result(res) - import + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_coo_csnmi end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csnm1 - interface + interface function psb_z_coo_csnm1(a) result(res) - import + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_coo_csnm1 end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_rowsum - interface - subroutine psb_z_coo_rowsum(d,a) - import + interface + subroutine psb_z_coo_rowsum(d,a) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_rowsum end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_arwsum - interface - subroutine psb_z_coo_arwsum(d,a) - import + interface + subroutine psb_z_coo_arwsum(d,a) + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_arwsum end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_colsum - interface - subroutine psb_z_coo_colsum(d,a) - import + interface + subroutine psb_z_coo_colsum(d,a) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_colsum end interface - !> + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_aclsum - interface - subroutine psb_z_coo_aclsum(d,a) - import + interface + subroutine psb_z_coo_aclsum(d,a) + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_aclsum end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_get_diag - interface - subroutine psb_z_coo_get_diag(a,d,info) - import + interface + subroutine psb_z_coo_get_diag(a,d,info) + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_get_diag end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scal - interface - subroutine psb_z_coo_scal(d,a,info,side) - import + interface + subroutine psb_z_coo_scal(d,a,info,side) + import class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_z_coo_scal end interface - - !> + + !> !! \memberof psb_z_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scals interface - subroutine psb_z_coo_scals(d,a,info) - import + subroutine psb_z_coo_scals(d,a,info) + import class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_scals end interface - + !> + !! \memberof psb_z_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_scalplusidentity + interface + subroutine psb_z_coo_scalplusidentity(d,a,info) + import + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_coo_scalplusidentity + end interface + ! + !! \memberof psb_z_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_spaxpby + interface + subroutine psb_z_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_coo_spaxpby + end interface + + ! + !! \memberof psb_z_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_cmpval + interface + function psb_z_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_z_coo_cmpval + end interface + + ! + !! \memberof psb_z_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_cmpmat + interface + function psb_z_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_z_coo_cmpmat + end interface + ! == ================= ! ! BASE interfaces @@ -2163,14 +2316,14 @@ module psb_z_base_mat_mod !> Function csput: !! \memberof psb_lz_base_sparse_mat - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of NZ triples !! (IA(i),JA(i),VAL(i)) !! record a new coefficient in A such that !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). - !! + !! !! The internal components IA,JA,VAL are reallocated as necessary. !! Constraints: !! - If the matrix A is in the BUILD state, then the method will @@ -2183,33 +2336,33 @@ module psb_z_base_mat_mod !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) !! according to the value of DUPLICATE. !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by - !! IMIN:IMAX,JMIN:JMAX will be ignored. - !! + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! !! \param nz number of triples in input !! \param ia(:) the input row indices !! \param ja(:) the input col indices !! \param val(:) the input coefficients - !! \param imin minimum row index - !! \param imax maximum row index - !! \param jmin minimum col index - !! \param jmax maximum col index + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index !! \param info return code !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) !! ! - interface - subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_csput_a end interface - - interface - subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + + interface + subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2217,43 +2370,43 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_csput_v end interface - + ! ! !> Function csgetrow: !! \memberof psb_lz_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getrow is the basic method by which the other (getblk, clip) can !! be implemented. - !! + !! !! Returns the set !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) !! each identifying the position of a nonzero in A - !! between row indices IMIN:IMAX; + !! between row indices IMIN:IMAX; !! IA,JA are reallocated as necessary. - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param nz the number of output coefficients !! \param ia(:) the output row indices !! \param ja(:) the output col indices !! \param val(:) the output coefficients !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_lz_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -2266,33 +2419,33 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_base_csgetrow end interface - + ! !> Function csgetblk: !! \memberof psb_lz_base_sparse_mat !! \brief Get a (subset of) row(s) - !! + !! !! getblk is very similar to getrow, except that the output !! is packaged in a psb_lz_coo_sparse_mat object - !! - !! \param imin the minimum row index we are interested in - !! \param imax the minimum row index we are interested in + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in !! \param b the output (sub)matrix !! \param info return code - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_lpk_), intent(in) :: imin,imax @@ -2303,34 +2456,34 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_base_csgetblk end interface - + ! ! !> Function csclip: !! \memberof psb_lz_base_sparse_mat !! \brief Get a submatrix. - !! + !! !! csclip is practically identical to getblk. !! One of them has to go away..... - !! + !! !! \param b the output submatrix !! \param info return code - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 - !! + !! ! - interface + interface subroutine psb_lz_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -2351,27 +2504,27 @@ module psb_z_base_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lz_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -2380,13 +2533,13 @@ module psb_z_base_mat_mod class(psb_lz_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_lz_base_tril end interface - + ! !> Function triu: !! \memberof psb_lz_base_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -2395,27 +2548,27 @@ module psb_z_base_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lz_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -2424,27 +2577,27 @@ module psb_z_base_mat_mod class(psb_lz_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_lz_base_triu end interface - - + + ! !> Function get_diag: !! \memberof psb_lz_base_sparse_mat - !! \brief Extract the diagonal of A. - !! + !! \brief Extract the diagonal of A. + !! !! D(i) = A(i:i), i=1:min(nrows,ncols) !! !! \param d(:) The output diagonal - !! \param info return code. - ! - interface - subroutine psb_lz_base_get_diag(a,d,info) - import + !! \param info return code. + ! + interface + subroutine psb_lz_base_get_diag(a,d,info) + import class(psb_lz_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_get_diag end interface - + ! !> Function mold: !! \memberof psb_lz_base_sparse_mat @@ -2454,10 +2607,10 @@ module psb_z_base_mat_mod !! for those compilers not yet supporting mold. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mold(a,b,info) - import + ! + interface + subroutine psb_lz_base_mold(a,b,info) + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2469,21 +2622,21 @@ module psb_z_base_mat_mod !> Function clone: !! \memberof psb_lz_base_sparse_mat !! \brief Allocate and clone a class(psb_lz_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. !! Should also be equivalent to calling mold and then copy, !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code - ! - interface + ! + interface subroutine psb_lz_base_clone(a,b, info) - import - implicit none + import + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_clone end interface @@ -2493,18 +2646,18 @@ module psb_z_base_mat_mod !> Function make_nonunit: !! \memberof psb_lz_base_make_nonunit !! \brief Given a matrix for which is_unit() is true, explicitly - !! store the unit diagonal and set is_unit() to false. + !! store the unit diagonal and set is_unit() to false. !! This is needed e.g. when scaling - ! - interface + ! + interface subroutine psb_lz_base_make_nonunit(a) - import - implicit none + import + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a end subroutine psb_lz_base_make_nonunit end interface - + ! !> Function cp_to_coo: !! \memberof psb_lz_base_sparse_mat @@ -2512,16 +2665,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_to_coo(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_to_coo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_to_coo end interface - + ! !> Function cp_from_coo: !! \memberof psb_lz_base_sparse_mat @@ -2529,16 +2682,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_from_coo(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_from_coo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_from_coo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2547,16 +2700,16 @@ module psb_z_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_to_fmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_to_fmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_to_fmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2565,16 +2718,16 @@ module psb_z_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_from_fmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_from_fmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_from_fmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_lz_base_sparse_mat @@ -2582,16 +2735,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_to_coo(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_to_coo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_to_coo end interface - + ! !> Function mv_from_coo: !! \memberof psb_lz_base_sparse_mat @@ -2599,16 +2752,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_from_coo(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_from_coo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_from_coo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2617,16 +2770,16 @@ module psb_z_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_to_fmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_to_fmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_to_fmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2635,17 +2788,17 @@ module psb_z_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_from_fmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_from_fmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_from_fmt end interface - + ! !> Function cp_to_coo: !! \memberof psb_lz_base_sparse_mat @@ -2653,16 +2806,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_to_icoo(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_to_icoo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_to_icoo end interface - + ! !> Function cp_from_coo: !! \memberof psb_lz_base_sparse_mat @@ -2670,16 +2823,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_from_icoo(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_from_icoo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_from_icoo end interface - + ! !> Function cp_to_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2688,16 +2841,16 @@ module psb_z_base_mat_mod !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_to_ifmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_to_ifmt end interface - + ! !> Function cp_from_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2706,16 +2859,16 @@ module psb_z_base_mat_mod !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_cp_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_cp_from_ifmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_cp_from_ifmt end interface - + ! !> Function mv_to_coo: !! \memberof psb_lz_base_sparse_mat @@ -2723,16 +2876,16 @@ module psb_z_base_mat_mod !! Invoked from the source object. !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_to_icoo(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_to_icoo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_to_icoo end interface - + ! !> Function mv_from_coo: !! \memberof psb_lz_base_sparse_mat @@ -2740,16 +2893,16 @@ module psb_z_base_mat_mod !! Invoked from the target object. !! \param b The input variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_from_icoo(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_from_icoo(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_from_icoo end interface - + ! !> Function mv_to_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2758,16 +2911,16 @@ module psb_z_base_mat_mod !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_to_ifmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_to_ifmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_mv_to_ifmt end interface - + ! !> Function mv_from_fmt: !! \memberof psb_lz_base_sparse_mat @@ -2776,10 +2929,10 @@ module psb_z_base_mat_mod !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). !! \param b The output variable !! \param info return code - ! - interface - subroutine psb_lz_base_mv_from_ifmt(a,b,info) - import + ! + interface + subroutine psb_lz_base_mv_from_ifmt(a,b,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2789,111 +2942,150 @@ module psb_z_base_mat_mod ! - !> + !> !! \memberof psb_lz_base_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros ! interface subroutine psb_lz_base_clean_zeros(a, info) - import + import class(psb_lz_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_clean_zeros end interface - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_maxval - interface + interface function psb_lz_coo_maxval(a) result(res) - import + import class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_coo_maxval end interface - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_csnmi - interface + interface function psb_lz_coo_csnmi(a) result(res) - import + import class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_coo_csnmi end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_csnm1 - interface + interface function psb_lz_coo_csnm1(a) result(res) - import + import class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_coo_csnm1 end interface - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_rowsum - interface - subroutine psb_lz_coo_rowsum(d,a) - import + interface + subroutine psb_lz_coo_rowsum(d,a) + import class(psb_lz_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_coo_rowsum end interface - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_arwsum - interface - subroutine psb_lz_coo_arwsum(d,a) - import + interface + subroutine psb_lz_coo_arwsum(d,a) + import class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_coo_arwsum end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_colsum - interface - subroutine psb_lz_coo_colsum(d,a) - import + interface + subroutine psb_lz_coo_colsum(d,a) + import class(psb_lz_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_coo_colsum end interface - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_aclsum - interface - subroutine psb_lz_coo_aclsum(d,a) - import + interface + subroutine psb_lz_coo_aclsum(d,a) + import class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_coo_aclsum end interface - + ! !> Function base_scals: !! \memberof psb_lz_base_sparse_mat !! \brief Scale a matrix by a single scalar value !! - !! \param d Scaling factor + !! \param d Scaling factor !! \param info return code ! - interface - subroutine psb_lz_base_scals(d,a,info) - import + interface + subroutine psb_lz_base_scals(d,a,info) + import class(psb_lz_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_base_scals end interface - + + ! + !> Function base_scalsplusidentity: + !! \memberof psb_lz_base_sparse_mat + !! \brief Scale a matrix by a single scalar value and adds identity + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_lz_base_scalplusidentity(d,a,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_scalplusidentity + end interface + ! + !> Function base_spaxpby: + !! \memberof psb_lz_base_sparse_mat + !! \brief Scale add tow sparse matrices A = alpha A + beta B + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param beta scaling for B + !! \param B sparse matrix B (intent in) + !! \param info return code + ! + interface + subroutine psb_lz_base_spaxpby(alpha,a,beta,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_spaxpby + end interface + + ! !> Function base_scal: !! \memberof psb_lz_base_sparse_mat @@ -2903,40 +3095,86 @@ module psb_z_base_mat_mod !! \param info return code !! \param side [L] Scale on the Left (rows) or on the Right (columns) ! - interface - subroutine psb_lz_base_scal(d,a,info,side) - import + interface + subroutine psb_lz_base_scal(d,a,info,side) + import class(psb_lz_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_lz_base_scal end interface - + + ! + !> Function base_cmpval: + !! \memberof psb_lz_base_sparse_mat + !! \brief Compare the element of A with the value val |A(i,j) -val| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param val comparing element for the entries of A + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_lz_base_cmpval(a,val,tol,info) result(res) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lz_base_cmpval + end interface + + ! + !> Function base_cmpmat: + !! \memberof psb_lz_base_sparse_mat + !! \brief Compare the element of A with the ones of B |A(i,j) - B(i,j)| < tol + !! + !! \param alpha scaling for A + !! \param A sparse matrix A (intent inout) + !! \param A sparse matrix B (intent inout) + !! \param tol tolerance to which the comparison is done + !! \param res return logical + !! \param info return code + ! + interface + function psb_lz_base_cmpmat(a,b,tol,info) result(res) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lz_base_cmpmat + end interface + ! !> Function base_maxval: !! \memberof psb_lz_base_sparse_mat !! \brief Maximum absolute value of all coefficients; - !! + !! ! - interface + interface function psb_lz_base_maxval(a) result(res) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_base_maxval end interface - + ! ! !> Function base_csnmi: !! \memberof psb_lz_base_sparse_mat !! \brief Operator infinity norm - !! + !! ! - interface + interface function psb_lz_base_csnmi(a) result(res) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_base_csnmi @@ -2947,11 +3185,11 @@ module psb_z_base_mat_mod !> Function base_csnmi: !! \memberof psb_lz_base_sparse_mat !! \brief Operator 1-norm - !! + !! ! - interface + interface function psb_lz_base_csnm1(a) result(res) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_base_csnm1 @@ -2963,11 +3201,11 @@ module psb_z_base_mat_mod !! \memberof psb_lz_base_sparse_mat !! \brief Sum along the rows !! \param d(:) The output row sums - !! + !! ! - interface - subroutine psb_lz_base_rowsum(d,a) - import + interface + subroutine psb_lz_base_rowsum(d,a) + import class(psb_lz_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_base_rowsum @@ -2978,26 +3216,26 @@ module psb_z_base_mat_mod !! \memberof psb_lz_base_sparse_mat !! \brief Absolute value sum along the rows !! \param d(:) The output row sums - !! - interface - subroutine psb_lz_base_arwsum(d,a) - import + !! + interface + subroutine psb_lz_base_arwsum(d,a) + import class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_base_arwsum end interface - + ! ! !> Function base_colsum: !! \memberof psb_lz_base_sparse_mat !! \brief Sum along the columns !! \param d(:) The output col sums - !! + !! ! - interface - subroutine psb_lz_base_colsum(d,a) - import + interface + subroutine psb_lz_base_colsum(d,a) + import class(psb_lz_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_base_colsum @@ -3008,76 +3246,76 @@ module psb_z_base_mat_mod !! \memberof psb_lz_base_sparse_mat !! \brief Absolute value sum along the columns !! \param d(:) The output col sums - !! - interface - subroutine psb_lz_base_aclsum(d,a) - import + !! + interface + subroutine psb_lz_base_aclsum(d,a) + import class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_base_aclsum end interface - + ! !> Function transp: !! \memberof psb_lz_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version !! \param b The output variable - ! - interface + ! + interface subroutine psb_lz_base_transp_2mat(a,b) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_lz_base_transp_2mat end interface - + ! !> Function transc: !! \memberof psb_lz_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! Copyout version. !! \param b The output variable - ! - interface + ! + interface subroutine psb_lz_base_transc_2mat(a,b) - import + import class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b end subroutine psb_lz_base_transc_2mat end interface - + ! !> Function transp: !! \memberof psb_lz_base_sparse_mat !! \brief Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_lz_base_transp_1mat(a) - import + import class(psb_lz_base_sparse_mat), intent(inout) :: a end subroutine psb_lz_base_transp_1mat end interface - + ! !> Function transc: !! \memberof psb_lz_base_sparse_mat !! \brief Conjugate Transpose. Can always be implemented by staging through a COO - !! temporary for which transpose is very easy. + !! temporary for which transpose is very easy. !! In-place version. - ! - interface + ! + interface subroutine psb_lz_base_transc_1mat(a) - import + import class(psb_lz_base_sparse_mat), intent(inout) :: a end subroutine psb_lz_base_transc_1mat end interface - + ! == =============== ! ! COO interfaces @@ -3085,82 +3323,82 @@ module psb_z_base_mat_mod ! == =============== ! - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reallocate_nz ! interface - subroutine psb_lz_coo_reallocate_nz(nz,a) - import + subroutine psb_lz_coo_reallocate_nz(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_lz_coo_sparse_mat), intent(inout) :: a end subroutine psb_lz_coo_reallocate_nz end interface ! - !> + !> !! \memberof psb_lz_coo_sparse_mat ! interface - subroutine psb_lz_coo_ensure_size(nz,a) - import + subroutine psb_lz_coo_ensure_size(nz,a) + import integer(psb_lpk_), intent(in) :: nz class(psb_lz_coo_sparse_mat), intent(inout) :: a end subroutine psb_lz_coo_ensure_size end interface - + ! - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_reinit ! - interface + interface subroutine psb_lz_coo_reinit(a,clear) - import - class(psb_lz_coo_sparse_mat), intent(inout) :: a + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lz_coo_reinit end interface ! - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_trim ! interface subroutine psb_lz_coo_trim(a) - import + import class(psb_lz_coo_sparse_mat), intent(inout) :: a end subroutine psb_lz_coo_trim end interface ! - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros ! interface subroutine psb_lz_coo_clean_zeros(a,info) - import + import class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_coo_clean_zeros end interface - + ! - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \brief Take out any entries with negative row or column index !! May happen when converting local/global numbering !! \param info return code - !! + !! ! interface subroutine psb_lz_coo_clean_negidx(a,info) - import + import class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_coo_clean_negidx end interface -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) ! !> Funtion: coo_clean_negidx_inner !! \brief Take out any entries with negative row or column index @@ -3171,11 +3409,11 @@ module psb_z_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! + !! ! interface psb_coo_clean_negidx_inner - subroutine psb_lz_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) - import + subroutine psb_lz_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) + import integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) @@ -3183,34 +3421,34 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_coo_clean_negidx_inner end interface psb_coo_clean_negidx_inner -#endif +#endif ! - !> + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_allocate_mnnz ! interface - subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) - import + subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) + import integer(psb_lpk_), intent(in) :: m,n class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_lz_coo_allocate_mnnz end interface - + !> \memberof psb_lz_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lz_coo_mold(a,b,info) - import + interface + subroutine psb_lz_coo_mold(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_coo_mold end interface - - + + ! !> Function print. !! \memberof psb_lz_coo_sparse_mat @@ -3225,17 +3463,17 @@ module psb_z_base_mat_mod ! interface subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) - import + import integer(psb_ipk_), intent(in) :: iout - class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lz_coo_print end interface - - - + + + ! !> Function get_nz_row. !! \memberof psb_lz_coo_sparse_mat @@ -3244,16 +3482,16 @@ module psb_z_base_mat_mod !! \param idx The row to search. !! ! - interface + interface function psb_lz_coo_get_nz_row(idx,a) result(res) - import + import class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res end function psb_lz_coo_get_nz_row end interface - - + + ! !> Funtion: fix_coo_inner !! \brief Make sure the entries are sorted and duplicates are handled. @@ -3265,12 +3503,12 @@ module psb_z_base_mat_mod !! \param val(:) Coefficients !! \param nzout Number of entries after sorting/duplicate handling !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order - !! + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! ! - interface - subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import + interface + subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import integer(psb_lpk_), intent(in) :: nr,nc,nzin integer(psb_ipk_), intent(in) :: dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -3280,164 +3518,164 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_lz_fix_coo_inner end interface - + ! !> Function fix_coo !! \memberof psb_lz_coo_sparse_mat !! \brief Make sure the entries are sorted and duplicates are handled. !! \param info return code - !! \param idir [psb_row_major_] Sort in row major order or col major order + !! \param idir [psb_row_major_] Sort in row major order or col major order !! ! - interface - subroutine psb_lz_fix_coo(a,info,idir) - import + interface + subroutine psb_lz_fix_coo(a,info,idir) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_lz_fix_coo end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo - interface - subroutine psb_lz_cp_coo_to_coo(a,b,info) - import + interface + subroutine psb_lz_cp_coo_to_coo(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_coo_to_coo end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo - interface - subroutine psb_lz_cp_coo_from_coo(a,b,info) - import + interface + subroutine psb_lz_cp_coo_from_coo(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_coo_from_coo end interface - - - !> + + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo - interface - subroutine psb_lz_cp_coo_to_icoo(a,b,info) - import + interface + subroutine psb_lz_cp_coo_to_icoo(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_coo_to_icoo end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo - interface - subroutine psb_lz_cp_coo_from_icoo(a,b,info) - import + interface + subroutine psb_lz_cp_coo_from_icoo(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_coo_from_icoo end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo - !! - interface - subroutine psb_lz_cp_coo_to_fmt(a,b,info) - import + !! + interface + subroutine psb_lz_cp_coo_to_fmt(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_coo_to_fmt end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt - !! - interface - subroutine psb_lz_cp_coo_from_fmt(a,b,info) - import + !! + interface + subroutine psb_lz_cp_coo_from_fmt(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_coo_from_fmt end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo - interface - subroutine psb_lz_mv_coo_to_coo(a,b,info) - import + interface + subroutine psb_lz_mv_coo_to_coo(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_coo_to_coo end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo - interface - subroutine psb_lz_mv_coo_from_coo(a,b,info) - import + interface + subroutine psb_lz_mv_coo_from_coo(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_coo_from_coo end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt - interface - subroutine psb_lz_mv_coo_to_fmt(a,b,info) - import + interface + subroutine psb_lz_mv_coo_to_fmt(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_coo_to_fmt end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt - interface - subroutine psb_lz_mv_coo_from_fmt(a,b,info) - import + interface + subroutine psb_lz_mv_coo_from_fmt(a,b,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_coo_from_fmt end interface - - interface + + interface subroutine psb_lz_coo_cp_from(a,b) - import + import class(psb_lz_coo_sparse_mat), intent(inout) :: a type(psb_lz_coo_sparse_mat), intent(in) :: b end subroutine psb_lz_coo_cp_from end interface - - interface + + interface subroutine psb_lz_coo_mv_from(a,b) - import + import class(psb_lz_coo_sparse_mat), intent(inout) :: a type(psb_lz_coo_sparse_mat), intent(inout) :: b end subroutine psb_lz_coo_mv_from end interface - - + + !> Function csput !! \memberof psb_lz_coo_sparse_mat !! \brief Add coefficients into the matrix. @@ -3454,9 +3692,9 @@ module psb_z_base_mat_mod !! \param gtl [none] Renumbering for rows/columns !! ! - interface - subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) - import + interface + subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& @@ -3464,14 +3702,14 @@ module psb_z_base_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_coo_csput_a end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3483,14 +3721,14 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_coo_csgetptn end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow - interface + interface subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import + import class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: imin,imax integer(psb_lpk_), intent(out) :: nz @@ -3503,39 +3741,39 @@ module psb_z_base_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_coo_csgetrow end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag - interface - subroutine psb_lz_coo_get_diag(a,d,info) - import + interface + subroutine psb_lz_coo_get_diag(a,d,info) + import class(psb_lz_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_coo_get_diag end interface - - - !> + + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scal - interface - subroutine psb_lz_coo_scal(d,a,info,side) - import + interface + subroutine psb_lz_coo_scal(d,a,info,side) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side end subroutine psb_lz_coo_scal end interface - - !> + + !> !! \memberof psb_lz_coo_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scals interface - subroutine psb_lz_coo_scals(d,a,info) - import + subroutine psb_lz_coo_scals(d,a,info) + import class(psb_lz_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3543,11 +3781,64 @@ module psb_z_base_mat_mod end interface public :: psb_z_get_print_frmt, psb_lz_get_print_frmt - + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scalplusidentity + interface + subroutine psb_lz_coo_scalplusidentity(d,a,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_scalplusidentity + end interface + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_spaxpby + interface + subroutine psb_lz_coo_spaxpby(alpha,a,beta,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_spaxpby + end interface + + ! + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cmpval + interface + function psb_lz_coo_cmpval(a,val,tol,info) result(res) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lz_coo_cmpval + end interface + + ! + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cmpmat + interface + function psb_lz_coo_cmpmat(a,b,tol,info) result(res) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lz_coo_cmpmat + end interface + contains - + function psb_z_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_ipk_), intent(in) :: nr, nc, nz @@ -3562,17 +3853,17 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_z_get_print_frmt - + function psb_lz_get_print_frmt(nr,nc,nz,iv,ivr,ivc) result(frmt) - + implicit none character(len=80) :: frmt integer(psb_lpk_), intent(in) :: nr, nc, nz @@ -3587,109 +3878,109 @@ contains if (present(ivr)) nmx = max(nmx,maxval(abs(ivr(1:nr)))) if (present(ivc)) nmx = max(nmx,maxval(abs(ivc(1:nc)))) ni = floor(log10(1.0*nmx)) + 2 - - if (datatype=='complex') then + + if (datatype=='complex') then write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - else + else write(frmt,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' end if - + end function psb_lz_get_print_frmt - - + + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function z_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%ia) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function z_coo_sizeof - - + + function z_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function z_coo_get_fmt - - + + function z_coo_get_size(a) result(res) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function z_coo_get_size - - + + function z_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%nnz end function z_coo_get_nzeros - + function z_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function z_coo_is_by_rows - + function z_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function z_coo_is_by_cols - + function z_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function z_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3697,52 +3988,52 @@ contains ! ! ! == ================================== - + subroutine z_coo_set_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine z_coo_set_nzeros - + function z_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_z_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function z_coo_get_sort_status - + subroutine z_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_z_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine z_coo_set_sort_status - - + + subroutine z_coo_set_by_rows(a) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine z_coo_set_by_rows - - + + subroutine z_coo_set_by_cols(a) - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine z_coo_set_by_cols - + ! == ================================== ! ! @@ -3754,12 +4045,12 @@ contains ! ! ! == ================================== - - subroutine z_coo_free(a) - implicit none - + + subroutine z_coo_free(a) + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -3768,13 +4059,13 @@ contains call a%set_ncols(0_psb_ipk_) call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine z_coo_free - - - + + + ! == ================================== ! ! @@ -3788,132 +4079,132 @@ contains ! ! == ================================== subroutine z_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a - - integer(psb_ipk_), allocatable :: itemp(:) + + integer(psb_ipk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_z_base_sparse_mat%psb_base_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine z_coo_transp_1mat - + subroutine z_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_z_is_complex_) a%val(:) = conjg(a%val(:)) end subroutine z_coo_transc_1mat - + ! == ================================== ! ! ! - ! Getters + ! Getters ! ! ! ! ! ! == ================================== - - - + + + function lz_coo_sizeof(a) result(res) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 3*psb_sizeof_lp res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%ia) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function lz_coo_sizeof - - + + function lz_coo_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'COO' end function lz_coo_get_fmt - - + + function lz_coo_get_size(a) result(res) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - + if (allocated(a%ia)) res = size(a%ia) - if (allocated(a%ja)) then - if (res >= 0) then + if (allocated(a%ja)) then + if (res >= 0) then res = min(res,size(a%ja)) - else + else res = size(a%ja) end if end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if end function lz_coo_get_size - - + + function lz_coo_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%nnz end function lz_coo_get_nzeros - + function lz_coo_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) end function lz_coo_is_by_rows - + function lz_coo_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_col_major_) end function lz_coo_is_by_cols - + function lz_coo_is_sorted(a) result(res) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a logical :: res res = (a%sort_status == psb_row_major_) & & .or.(a%sort_status == psb_col_major_) end function lz_coo_is_sorted - - - + + + ! == ================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -3921,63 +4212,63 @@ contains ! ! ! == ================================== - + subroutine lz_coo_iset_nzeros(nz,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_lz_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine lz_coo_iset_nzeros #if defined(IPK4) && defined(LPK8) subroutine lz_coo_lset_nzeros(nz,a) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lz_coo_sparse_mat), intent(inout) :: a - + a%nnz = nz - + end subroutine lz_coo_lset_nzeros #endif - + function lz_coo_get_sort_status(a) result(res) - implicit none + implicit none integer(psb_ipk_) :: res class(psb_lz_coo_sparse_mat), intent(in) :: a - + res = a%sort_status end function lz_coo_get_sort_status - + subroutine lz_coo_set_sort_status(ist,a) - implicit none + implicit none integer(psb_ipk_), intent(in) :: ist class(psb_lz_coo_sparse_mat), intent(inout) :: a - + a%sort_status = ist call a%set_sorted((a%sort_status == psb_row_major_) & - & .or.(a%sort_status == psb_col_major_)) + & .or.(a%sort_status == psb_col_major_)) end subroutine lz_coo_set_sort_status - - + + subroutine lz_coo_set_by_rows(a) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_row_major_ call a%set_sorted() end subroutine lz_coo_set_by_rows - - + + subroutine lz_coo_set_by_cols(a) - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a - + a%sort_status = psb_col_major_ call a%set_sorted() end subroutine lz_coo_set_by_cols - + ! == ================================== ! ! @@ -3989,12 +4280,12 @@ contains ! ! ! == ================================== - - subroutine lz_coo_free(a) - implicit none - + + subroutine lz_coo_free(a) + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a - + if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) @@ -4003,13 +4294,13 @@ contains call a%set_ncols(0_psb_lpk_) call a%set_nzeros(0_psb_lpk_) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine lz_coo_free - - - + + + ! == ================================== ! ! @@ -4023,40 +4314,37 @@ contains ! ! == ================================== subroutine lz_coo_transp_1mat(a) - implicit none - + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a - - integer(psb_lpk_), allocatable :: itemp(:) + + integer(psb_lpk_), allocatable :: itemp(:) integer(psb_ipk_) :: info - + call a%psb_lz_base_sparse_mat%psb_lbase_sparse_mat%transp() call move_alloc(a%ia,itemp) call move_alloc(a%ja,a%ia) call move_alloc(itemp,a%ja) - + call a%set_sorted(.false.) call a%set_sort_status(psb_unsorted_) - + return - + end subroutine lz_coo_transp_1mat - + subroutine lz_coo_transc_1mat(a) - implicit none - + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a - - call a%transp() + + call a%transp() ! This will morph into conjg() for C and Z ! and into a no-op for S and D, so a conditional - ! on a constant ought to take it out completely. + ! on a constant ought to take it out completely. if (psb_lz_is_complex_) a%val(:) = conjg(a%val(:)) end subroutine lz_coo_transc_1mat end module psb_z_base_mat_mod - - - diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index 6dd242cc3..f44f31db8 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_z_base_vect_mod ! ! This module contains the definition of the psb_z_base_vect type which ! is a container for dense vectors. -! This is encapsulated instead of being just a simple array to allow for +! This is encapsulated instead of being just a simple array to allow for ! more complicated situations, such as GPU programming, where the memory ! area we are interested in is not easily accessible from the host/Fortran ! side. It is also meant to be encapsulated in an outer type, to allow @@ -43,7 +43,7 @@ ! ! module psb_z_base_vect_mod - + use psb_const_mod use psb_error_mod use psb_realloc_mod @@ -51,9 +51,9 @@ module psb_z_base_vect_mod use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_z_base_vect_type - !! The psb_z_base_vect_type + !! The psb_z_base_vect_type !! defines a middle level complex(psb_dpk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow @@ -61,9 +61,9 @@ module psb_z_base_vect_mod !! sparse matrix types. !! type psb_z_base_vect_type - !> Values. + !> Values. complex(psb_dpk_), allocatable :: v(:) - complex(psb_dpk_), allocatable :: combuf(:) + complex(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -78,7 +78,7 @@ module psb_z_base_vect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins_a => z_base_ins_a procedure, pass(x) :: ins_v => z_base_ins_v @@ -93,7 +93,7 @@ module psb_z_base_vect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => z_base_sync procedure, pass(x) :: is_host => z_base_is_host @@ -130,7 +130,7 @@ module psb_z_base_vect_mod generic, public :: set => set_vect, set_scal ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => z_base_gthab procedure, pass(x) :: gthzv => z_base_gthzv @@ -151,7 +151,9 @@ module psb_z_base_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => z_base_axpby_v procedure, pass(y) :: axpby_a => z_base_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => z_base_axpby_v2 + procedure, pass(z) :: axpby_a2 => z_base_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 ! ! Vector by vector multiplication. Need all variants ! to handle multiple requirements from preconditioners @@ -162,7 +164,24 @@ module psb_z_base_vect_mod procedure, pass(z) :: mlt_v_2 => z_base_mlt_v_2 procedure, pass(z) :: mlt_va => z_base_mlt_va procedure, pass(z) :: mlt_av => z_base_mlt_av - generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va + generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, & + mlt_va + ! + ! Vector-Vector operations + ! + procedure, pass(x) :: div_v => z_base_div_v + procedure, pass(x) :: div_v_check => z_base_div_v_check + procedure, pass(z) :: div_v2 => z_base_div_v2 + procedure, pass(z) :: div_v2_check => z_base_div_v2_check + procedure, pass(z) :: div_a2 => z_base_div_a2 + procedure, pass(z) :: div_a2_check => z_base_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => z_base_inv_v + procedure, pass(y) :: inv_v_check => z_base_inv_v_check + procedure, pass(y) :: inv_a2 => z_base_inv_a2 + procedure, pass(y) :: inv_a2_check => z_base_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check ! ! Scaling and norms ! @@ -174,6 +193,22 @@ module psb_z_base_vect_mod procedure, pass(x) :: amax => z_base_amax procedure, pass(x) :: asum => z_base_asum + ! + ! Comparison and mask operation + ! + procedure, pass(z) :: acmp_a2 => z_base_acmp_a2 + procedure, pass(z) :: acmp_v2 => z_base_acmp_v2 + generic, public :: acmp => acmp_a2,acmp_v2 + ! + ! Add constant value to all entry of a vector + ! + procedure, pass(z) :: addconst_a2 => z_base_addconst_a2 + procedure, pass(z) :: addconst_v2 => z_base_addconst_v2 + generic, public :: addconst => addconst_a2,addconst_v2 + + + + end type psb_z_base_vect_type public :: psb_z_base_vect @@ -183,11 +218,11 @@ module psb_z_base_vect_mod end interface psb_z_base_vect contains - + ! - ! Constructors. + ! Constructors. ! - + !> Function constructor: !! \brief Constructor from an array !! \param x(:) input array to be copied @@ -200,11 +235,11 @@ contains this%v = x call this%asb(size(x,kind=psb_ipk_),info) end function constructor - - + + !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(n) result(this) integer(psb_ipk_), intent(in) :: n @@ -214,7 +249,7 @@ contains call this%asb(n,info) end function size_const - + ! ! Build from a sample ! @@ -226,20 +261,20 @@ contains !! subroutine z_base_bld_x(x,this) use psb_realloc_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: this(:) class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(size(this),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') return end if x%v(:) = this(:) end subroutine z_base_bld_x - + ! ! Create with size, but no initialization ! @@ -247,11 +282,11 @@ contains !> Function bld_mn: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine z_base_bld_mn(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -260,15 +295,15 @@ contains call x%asb(n,info) end subroutine z_base_bld_mn - + !> Function bld_en: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine z_base_bld_en(x,n) use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info @@ -277,24 +312,24 @@ contains call x%asb(n,info) end subroutine z_base_bld_en - + !> Function base_all: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine z_base_all(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_base_vect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info - + call psb_realloc(n,x%v,info) - + end subroutine z_base_all !> Function base_mold: @@ -306,11 +341,11 @@ contains subroutine z_base_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x class(psb_z_base_vect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info - + allocate(psb_z_base_vect_type :: y, stat=info) end subroutine z_base_mold @@ -320,21 +355,21 @@ contains ! !> Function base_ins: !! \memberof psb_z_base_vect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -344,7 +379,7 @@ contains ! subroutine z_base_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -354,21 +389,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -376,7 +411,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -394,7 +429,7 @@ contains end select end if call x%set_host() - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -403,7 +438,7 @@ contains subroutine z_base_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_base_vect_type), intent(inout) :: irl @@ -413,14 +448,14 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return if (irl%is_dev()) call irl%sync() if (val%is_dev()) call val%sync() if (x%is_dev()) call x%sync() call x%ins(n,irl%v,val%v,dupl,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_vect_ins') return end if @@ -436,14 +471,14 @@ contains ! subroutine z_base_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x - + if (allocated(x%v)) x%v=zzero call x%set_host() end subroutine z_base_zero - + ! ! Assembly. ! For derived classes: after this the vector @@ -452,20 +487,20 @@ contains !> Function base_asb: !! \memberof psb_z_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine z_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -482,20 +517,20 @@ contains !> Function base_asb: !! \memberof psb_z_base_vect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! ! - + subroutine z_base_asb_e(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (x%get_nrows() < n) & & call psb_realloc(n,x%v,info) @@ -508,39 +543,39 @@ contains !> Function base_free: !! \memberof psb_z_base_vect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine z_base_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - + info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) if (info == 0) call x%free_buffer(info) if (info == 0) call x%free_comid(info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') - + end subroutine z_base_free - + ! !> Function base_free_buffer: !! \memberof psb_z_base_vect_type !! \brief Free aux buffer - !! + !! !! \param info return code !! ! subroutine z_base_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -555,17 +590,17 @@ contains !! In some derived classes, e.g. GPU, !! does not really frees to avoid runtime !! costs - !! + !! !! \param info return code !! ! subroutine z_base_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -575,13 +610,13 @@ contains !> Function base_free_comid: !! \memberof psb_z_base_vect_type !! \brief Free aux MPI communication id buffer - !! + !! !! \param info return code !! ! subroutine z_base_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -593,77 +628,77 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_sync: !! \memberof psb_z_base_vect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine z_base_sync(x) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x - + end subroutine z_base_sync ! !> Function base_set_host: !! \memberof psb_z_base_vect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine z_base_set_host(x) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x - + end subroutine z_base_set_host ! !> Function base_set_dev: !! \memberof psb_z_base_vect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine z_base_set_dev(x) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x - + end subroutine z_base_set_dev ! !> Function base_set_sync: !! \memberof psb_z_base_vect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine z_base_set_sync(x) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x - + end subroutine z_base_set_sync ! !> Function base_is_dev: !! \memberof psb_z_base_vect_type !! \brief Is vector on external device . - !! + !! ! function z_base_is_dev(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x logical :: res - + res = .false. end function z_base_is_dev - + ! !> Function base_is_host !! \memberof psb_z_base_vect_type !! \brief Is vector on standard memory . - !! + !! ! function z_base_is_host(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x logical :: res @@ -674,10 +709,10 @@ contains !> Function base_is_sync !! \memberof psb_z_base_vect_type !! \brief Is vector on sync . - !! + !! ! function z_base_is_sync(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x logical :: res @@ -686,16 +721,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_get_nrows !! \memberof psb_z_base_vect_type !! \brief Number of entries - !! + !! ! function z_base_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -708,13 +743,13 @@ contains !> Function base_get_sizeof !! \memberof psb_z_base_vect_type !! \brief Size in bytes - !! + !! ! function z_base_sizeof(x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(in) :: x integer(psb_epk_) :: res - + ! Force 8-byte integers. res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() @@ -724,14 +759,14 @@ contains !> Function base_get_fmt !! \memberof psb_z_base_vect_type !! \brief Format - !! + !! ! function z_base_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function z_base_get_fmt - + ! ! @@ -740,7 +775,7 @@ contains !! \memberof psb_z_base_vect_type !! \brief Extract a copy of the contents !! - ! + ! function z_base_get_vect(x,n) result(res) class(psb_z_base_vect_type), intent(inout) :: x complex(psb_dpk_), allocatable :: res(:) @@ -748,21 +783,21 @@ contains integer(psb_ipk_), optional :: n ! Local variables integer(psb_ipk_) :: isz - - if (.not.allocated(x%v)) return + + if (.not.allocated(x%v)) return if (.not.x%is_host()) call x%sync() isz = x%get_nrows() if (present(n)) isz = max(0,min(isz,n)) - allocate(res(isz),stat=info) - if (info /= 0) then + allocate(res(isz),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') return end if res(1:isz) = x%v(1:isz) end function z_base_get_vect - + ! - ! Reset all values + ! Reset all values ! ! !> Function base_set_scal @@ -771,18 +806,18 @@ contains !! \param val The value to set !! subroutine z_base_set_scal(x,val,first,last) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_ first_=1 last_=size(x%v) if (present(first)) first_ = max(1,first) if (present(last)) last_ = min(last,last_) - + if (x%is_dev()) call x%sync() x%v(first_:last_) = val call x%set_host() @@ -794,14 +829,14 @@ contains !> Function base_set_vect !! \memberof psb_z_base_vect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine z_base_set_vect(x,val,first,last) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), optional :: first, last - + integer(psb_ipk_) :: info, first_, last_, nr first_ = 1 @@ -809,7 +844,7 @@ contains last_ = min(psb_size(x%v),first_+size(val)-1) if (present(last)) last_ = min(last,last_) - if (allocated(x%v)) then + if (allocated(x%v)) then if (x%is_dev()) call x%sync() x%v(first_:last_) = val(1:last_-first_+1) else @@ -829,7 +864,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine z_base_absval1(x) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x if (allocated(x%v)) then @@ -841,21 +876,21 @@ contains end subroutine z_base_absval1 subroutine z_base_absval2(x,y) - implicit none - class(psb_z_base_vect_type), intent(inout) :: x + implicit none + class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: y integer(psb_ipk_) :: info if (.not.x%is_host()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(ione*min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) call y%absval() end if - + end subroutine z_base_absval2 ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_dot_v !! \memberof psb_z_base_vect_type @@ -864,12 +899,12 @@ contains !! \param y The other (base_vect) to be multiplied by !! function z_base_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_dpk_) :: res complex(psb_dpk_), external :: zdotc - + res = zzero ! ! Note: this is the base implementation. @@ -898,19 +933,19 @@ contains !! \param y(:) The array to be multiplied by !! function z_base_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n complex(psb_dpk_) :: res complex(psb_dpk_), external :: zdotc - + res = zdotc(n,y,1,x%v,1) end function z_base_dot_a - + ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -925,13 +960,13 @@ contains !! subroutine z_base_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (x%is_dev()) call x%sync() call y%axpby(m,alpha,x%v,beta,info) @@ -939,7 +974,39 @@ contains end subroutine z_base_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + ! + !> Function base_axpby_v2 + !! \memberof psb_z_base_vect_type + !! \brief AXPBY by a (base_vect) z=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x The class(base_vect) to be added + !! \param beta scalar alpha + !! \param y The class(base_vect) to be added + !! \param z The class(base_vect) to be returned + !! \param info return code + !! + subroutine z_base_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (x%is_dev()) call x%sync() + + call z%axpby(m,alpha,x%v,beta,y%v,info) + + end subroutine z_base_axpby_v2 + + ! + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_axpby_a @@ -953,20 +1020,50 @@ contains !! subroutine z_base_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent(in) :: x(:) class(psb_z_base_vect_type), intent(inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - + if (y%is_dev()) call y%sync() call psb_geaxpby(m,alpha,x,beta,y%v,info) call y%set_host() - + end subroutine z_base_axpby_a - + ! + ! AXPBY is invoked via Z, hence the structure below. + ! + ! + !> Function base_axpby_a2 + !! \memberof psb_z_base_vect_type + !! \brief AXPBY by a normal array y=alpha*x+beta*y + !! \param m Number of entries to be considered + !! \param alpha scalar alpha + !! \param x(:) The array to be added + !! \param beta scalar beta + !! \param y(:) The array to be added + !! \param info return code + !! + subroutine z_base_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (z%is_dev()) call z%sync() + call psb_geaxpby(m,alpha,x,beta,y,z%v,info) + call z%set_host() + + end subroutine z_base_axpby_a2 + + ! ! Multiple variants of two operations: ! Simple multiplication Y(:) = X(:)*Y(:) @@ -984,10 +1081,10 @@ contains !! subroutine z_base_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1005,7 +1102,7 @@ contains !! subroutine z_base_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:) class(psb_z_base_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -1014,7 +1111,7 @@ contains info = 0 if (y%is_dev()) call y%sync() n = min(size(y%v), size(x)) - do i=1, n + do i=1, n y%v(i) = y%v(i)*x(i) end do call y%set_host() @@ -1035,7 +1132,7 @@ contains !! subroutine z_base_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) complex(psb_dpk_), intent(in) :: x(:) @@ -1043,58 +1140,58 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (z%is_dev()) call z%sync() n = min(size(z%v), size(x), size(y)) - if (alpha == zzero) then - if (beta == zone) then - return + if (alpha == zzero) then + if (beta == zone) then + return else do i=1, n z%v(i) = beta*z%v(i) end do end if else - if (alpha == zone) then - if (beta == zzero) then - do i=1, n + if (alpha == zone) then + if (beta == zzero) then + do i=1, n z%v(i) = y(i)*x(i) end do - else if (beta == zone) then - do i=1, n + else if (beta == zone) then + do i=1, n z%v(i) = z%v(i) + y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + y(i)*x(i) end do end if - else if (alpha == -zone) then - if (beta == zzero) then - do i=1, n + else if (alpha == -zone) then + if (beta == zzero) then + do i=1, n z%v(i) = -y(i)*x(i) end do - else if (beta == zone) then - do i=1, n + else if (beta == zone) then + do i=1, n z%v(i) = z%v(i) - y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) - y(i)*x(i) end do end if else - if (beta == zzero) then - do i=1, n + if (beta == zzero) then + do i=1, n z%v(i) = alpha*y(i)*x(i) end do - else if (beta == zone) then - do i=1, n + else if (beta == zone) then + do i=1, n z%v(i) = z%v(i) + alpha*y(i)*x(i) end do - else - do i=1, n + else + do i=1, n z%v(i) = beta*z%v(i) + alpha*y(i)*x(i) end do end if @@ -1118,12 +1215,12 @@ contains subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: y class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -1133,7 +1230,7 @@ contains if (x%is_dev()) call x%sync() if (.not.psb_z_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -1148,12 +1245,12 @@ contains subroutine z_base_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: x(:) class(psb_z_base_vect_type), intent(inout) :: y class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1164,12 +1261,12 @@ contains subroutine z_base_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -1177,10 +1274,318 @@ contains call z%mlt(alpha,y,x,beta,info) end subroutine z_base_mlt_va + ! + !> Function base_div_v + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine z_base_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info) + + + end subroutine z_base_div_v + ! + !> Function base_div_v2 + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine z_base_div_v2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info) + + + end subroutine z_base_div_v2 + ! + !> Function base_div_v_check + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector x=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine z_base_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (x%is_dev()) call x%sync() + call x%div(x%v,y%v,info,flag) + + + end subroutine z_base_div_v_check + ! + !> Function base_div_v2_check + !! \memberof psb_z_base_vect_type + !! \brief Vector entry-by-entry divide by a vector z=x/y + !! \param y The array to be divided by + !! \param info return code + !! + subroutine z_base_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (z%is_dev()) call z%sync() + call z%div(x%v,y%v,info,flag) + + + end subroutine z_base_div_v2_check + ! + !> Function base_div_a2 + !! \memberof psb_z_base_vect_type + !! \brief Entry-by-entry divide between normal array z=x/y + !! \param y(:) The array to be divided by + !! \param info return code + !! + subroutine z_base_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + z%v(i) = x(i)/y(i) + end do + + end subroutine z_base_div_a2 + ! + !> Function base_div_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Entry-by-entry divide between normal array x=x/y and check if y(i) + !! is different from zero + !! \param y(:) The array to be dived by + !! \param info return code + !! + subroutine z_base_div_a2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: z + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call z_base_div_a2(x, y, z, info) + else + info = 0 + if (z%is_dev()) call z%sync() + + n = min(size(y), size(x)) + do i=1, n + if (y(i) /= 0) then + z%v(i) = x(i)/y(i) + else + info = 1 + exit + end if + end do + end if + + + end subroutine z_base_div_a2_check + ! + !> Function base_inv_v + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + subroutine z_base_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info) + + + end subroutine z_base_inv_v + ! + !> Function base_inv_v_check + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x The vector to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + subroutine z_base_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (y%is_dev()) call y%sync() + call y%inv(x%v,info,flag) + + + end subroutine z_base_inv_v_check + ! + !> Function base_inv_a2 + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + ! + subroutine z_base_inv_a2(x, y, info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + y%v(i) = 1_psb_dpk_/x(i) + end do + + end subroutine z_base_inv_a2 + ! + !> Function base_inv_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Compute the entry-by-entry inverse of x and put it in y, with 0 check + !! \param x(:) The array to be inverted + !! \param y The vector containing the inverted vector + !! \param info return code + !! \param flag if true does the check, otherwise call base_inv_v + ! + subroutine z_base_inv_a2_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: y + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + integer(psb_ipk_) :: i, n + + if (flag .eqv. .false.) then + call z_base_inv_a2(x, y, info) + else + info = 0 + if (y%is_dev()) call y%sync() + + n = size(x) + do i=1, n + if (x(i) /= 0) then + y%v(i) = 1_psb_dpk_/x(i) + else + info = 1 + y%v(i) = 0_psb_dpk_ + end if + end do + end if + + + end subroutine z_base_inv_a2_check ! - ! Simple scaling + !> Function base_inv_a2_check + !! \memberof psb_z_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The array to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine z_base_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + if ( abs(x(i)).ge.c ) then + z%v(i) = 1_psb_dpk_ + else + z%v(i) = 0_psb_dpk_ + end if + end do + info = 0 + + end subroutine z_base_acmp_a2 + ! + !> Function base_cmp_v2 + !! \memberof psb_z_base_vect_type + !! \brief Compare entry-by-entry the vector x with the scalar c + !! \param x The vector to be compared + !! \param z The vector containing in position i 1 if |x(i)| > c, 0 otherwise + !! \param c The comparison term + !! \param info return code + ! + subroutine z_base_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: c + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%acmp(x%v,c,info) + end subroutine z_base_acmp_v2 + + ! + ! Simple scaling ! !> Function base_scal !! \memberof psb_z_base_vect_type @@ -1189,17 +1594,17 @@ contains !! subroutine z_base_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha - - if (allocated(x%v)) then + + if (allocated(x%v)) then x%v = alpha*x%v call x%set_host() end if end subroutine z_base_scal - + ! ! Norms 1, 2 and infinity ! @@ -1208,50 +1613,51 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function z_base_nrm2(n,x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res real(psb_dpk_), external :: dznrm2 - + if (x%is_dev()) call x%sync() res = dznrm2(n,x%v,1) end function z_base_nrm2 - + ! !> Function base_amax !! \memberof psb_z_base_vect_type !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function z_base_amax(n,x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = maxval(abs(x%v(1:n))) end function z_base_amax + ! !> Function base_asum !! \memberof psb_z_base_vect_type !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function z_base_asum(n,x) result(res) - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - + if (x%is_dev()) call x%sync() res = sum(abs(x%v(1:n))) end function z_base_asum - - + + ! ! Gather: Y = beta * Y + alpha * X(IDX(:)) ! @@ -1266,18 +1672,18 @@ contains !! \param beta subroutine z_base_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: alpha, beta, y(:) class(psb_z_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,alpha,x%v,beta,y) end subroutine z_base_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_z_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1286,28 +1692,28 @@ contains !! \param idx(:) indices subroutine z_base_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: y(:) class(psb_z_base_vect_type) :: x - + if (idx%is_dev()) call idx%sync() call x%gth(n,idx%v(i:),y) end subroutine z_base_gthzv_x ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine z_base_gthzbuf(i,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx class(psb_z_base_vect_type) :: x - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -1320,22 +1726,22 @@ contains !> Function base_device_wait: !! \memberof psb_z_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine z_base_device_wait() - implicit none - + implicit none + end subroutine z_base_device_wait function z_base_use_buffer() result(res) logical :: res - + res = .true. end function z_base_use_buffer subroutine z_base_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1345,7 +1751,7 @@ contains subroutine z_base_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -1356,7 +1762,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_gthzv !! \memberof psb_z_base_vect_type !! \brief gather into an array special alpha=1 beta=0 @@ -1365,20 +1771,20 @@ contains !! \param idx(:) indices subroutine z_base_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: y(:) class(psb_z_base_vect_type) :: x - + if (x%is_dev()) call x%sync() call psi_gth(n,idx,x%v,y) end subroutine z_base_gthzv ! - ! Scatter: + ! Scatter: ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) - ! + ! ! !> Function base_sctb !! \memberof psb_z_base_vect_type @@ -1387,14 +1793,14 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine z_base_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:) class(psb_z_base_vect_type) :: y - + if (y%is_dev()) call y%sync() call psi_sct(n,idx,x,beta,y%v) call y%set_host() @@ -1403,12 +1809,12 @@ contains subroutine z_base_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: beta, x(:) class(psb_z_base_vect_type) :: y - + if (idx%is_dev()) call idx%sync() call y%sct(n,idx%v(i:),x,beta) call y%set_host() @@ -1417,14 +1823,14 @@ contains subroutine z_base_sctb_buf(i,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: beta class(psb_z_base_vect_type) :: y - - - if (.not.allocated(y%combuf)) then + + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -1435,6 +1841,55 @@ contains end subroutine z_base_sctb_buf + + ! + !> Function _base_addconst_a2 + !! \memberof psb_z_base_vect_type + !! \brief Add the constant b to every entry of the array x + !! \param x The input array + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine z_base_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: b + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + if (z%is_dev()) call z%sync() + + n = size(x) + do i = 1, n, 1 + z%v(i) = x(i) + b + end do + info = 0 + + end subroutine z_base_addconst_a2 + ! + !> Function _base_addconst_v2 + !! \memberof psb_z_base_vect_type + !! \briefAdd the constant b to every entry of the vector x + !! \param x The input vector + !! \param z The vector containing the x(i) + b + !! \param b The added term + !! \param info return code + ! + subroutine z_base_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + real(psb_dpk_), intent(in) :: b + class(psb_z_base_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%is_dev()) call x%sync() + call z%addconst(x%v,b,info) + end subroutine z_base_addconst_v2 end module psb_z_base_vect_mod @@ -1449,22 +1904,22 @@ module psb_z_base_multivect_mod use psb_z_base_vect_mod !> \namespace psb_base_mod \class psb_z_base_vect_type - !! The psb_z_base_vect_type + !! The psb_z_base_vect_type !! defines a middle level integer(psb_ipk_) encapsulated dense vector. - !! The encapsulation is needed, in place of a simple array, to allow + !! The encapsulation is needed, in place of a simple array, to allow !! for complicated situations, such as GPU programming, where the memory !! area we are interested in is not easily accessible from the host/Fortran !! side. It is also meant to be encapsulated in an outer type, to allow !! runtime switching as per the STATE design pattern, similar to the !! sparse matrix types. !! - private + private public :: psb_z_base_multivect, psb_z_base_multivect_type type psb_z_base_multivect_type - !> Values. + !> Values. complex(psb_dpk_), allocatable :: v(:,:) - complex(psb_dpk_), allocatable :: combuf(:) + complex(psb_dpk_), allocatable :: combuf(:) integer(psb_mpk_), allocatable :: comid(:,:) contains ! @@ -1478,7 +1933,7 @@ module psb_z_base_multivect_mod ! ! Insert/set. Assembly and free. ! Assembly does almost nothing here, but is important - ! in derived classes. + ! in derived classes. ! procedure, pass(x) :: ins => z_base_mlv_ins procedure, pass(x) :: zero => z_base_mlv_zero @@ -1489,7 +1944,7 @@ module psb_z_base_multivect_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(x) :: sync => z_base_mlv_sync procedure, pass(x) :: is_host => z_base_mlv_is_host @@ -1562,7 +2017,7 @@ module psb_z_base_multivect_mod ! ! Gather/scatter. These are needed for MPI interfacing. - ! May have to be reworked. + ! May have to be reworked. ! procedure, pass(x) :: gthab => z_base_mlv_gthab procedure, pass(x) :: gthzv => z_base_mlv_gthzv @@ -1584,7 +2039,7 @@ module psb_z_base_multivect_mod contains ! - ! Constructors. + ! Constructors. ! !> Function constructor: @@ -1603,7 +2058,7 @@ contains !> Function constructor: !! \brief Constructor from size - !! \param n Size of vector to be built. + !! \param n Size of vector to be built. !! function size_const(m,n) result(this) integer(psb_ipk_), intent(in) :: m,n @@ -1630,7 +2085,7 @@ contains integer(psb_ipk_) :: info call psb_realloc(size(this,1),size(this,2),x%v,info) - if (info /= 0) then + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') return end if @@ -1645,7 +2100,7 @@ contains !> Function bld_n: !! \memberof psb_z_base_multivect_type !! \brief Build method with size (uninitialized data) - !! \param n size to be allocated. + !! \param n size to be allocated. !! subroutine z_base_mlv_bld_n(x,m,n) use psb_realloc_mod @@ -1662,13 +2117,13 @@ contains !! \memberof psb_z_base_multivect_type !! \brief Build method with size (uninitialized data) and !! allocation return code. - !! \param n size to be allocated. + !! \param n size to be allocated. !! \param info return code !! subroutine z_base_mlv_all(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(out) :: x integer(psb_ipk_), intent(out) :: info @@ -1686,7 +2141,7 @@ contains subroutine z_base_mlv_mold(x, y, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x class(psb_z_base_multivect_type), intent(out), allocatable :: y integer(psb_ipk_), intent(out) :: info @@ -1700,21 +2155,21 @@ contains ! !> Function base_mlv_ins: !! \memberof psb_z_base_multivect_type - !! \brief Insert coefficients. + !! \brief Insert coefficients. !! !! !! Given a list of N pairs !! (IRL(i),VAL(i)) !! record a new coefficient in X such that !! X(IRL(1:N)) = VAL(1:N). - !! + !! !! - the update operation will perform either !! X(IRL(1:n)) = VAL(1:N) !! or !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) !! according to the value of DUPLICATE. - !! - !! + !! + !! !! \param n number of pairs in input !! \param irl(:) the input row indices !! \param val(:) the input coefficients @@ -1724,7 +2179,7 @@ contains ! subroutine z_base_mlv_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1734,21 +2189,21 @@ contains integer(psb_ipk_) :: i, isz info = 0 - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ - else if (n > min(size(irl),size(val))) then + else if (n > min(size(irl),size(val))) then info = psb_err_invalid_input_ - else + else isz = size(x%v,1) - select case(dupl) - case(psb_dupl_ovwrt_) + select case(dupl) + case(psb_dupl_ovwrt_) do i = 1, n !loop over all val's rows - ! row actual block row + ! row actual block row if ((1 <= irl(i)).and.(irl(i) <= isz)) then ! this row belongs to me ! copy i-th row of block val in x @@ -1756,7 +2211,7 @@ contains end if enddo - case(psb_dupl_add_) + case(psb_dupl_add_) do i = 1, n !loop over all val's rows @@ -1773,7 +2228,7 @@ contains ! !$ goto 9999 end select end if - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,'base_mlv_vect_ins') return end if @@ -1788,7 +2243,7 @@ contains ! subroutine z_base_mlv_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x if (allocated(x%v)) x%v=zzero @@ -1804,7 +2259,7 @@ contains !> Function base_mlv_asb: !! \memberof psb_z_base_multivect_type !! \brief Assemble vector: reallocate as necessary. - !! + !! !! \param n final size !! \param info return code !! @@ -1813,7 +2268,7 @@ contains subroutine z_base_mlv_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1830,20 +2285,20 @@ contains !> Function base_mlv_free: !! \memberof psb_z_base_multivect_type !! \brief Free vector - !! + !! !! \param info return code !! ! subroutine z_base_mlv_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 if (allocated(x%v)) deallocate(x%v, stat=info) - if (info /= 0) call & + if (info /= 0) call & & psb_errpush(psb_err_alloc_dealloc_,'vect_free') end subroutine z_base_mlv_free @@ -1853,15 +2308,15 @@ contains ! ! The base version of SYNC & friends does nothing, it's just ! a placeholder. - ! + ! ! !> Function base_mlv_sync: !! \memberof psb_z_base_multivect_type !! \brief Sync: base version is a no-op. - !! + !! ! subroutine z_base_mlv_sync(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_sync @@ -1870,10 +2325,10 @@ contains !> Function base_mlv_set_host: !! \memberof psb_z_base_multivect_type !! \brief Set_host: base version is a no-op. - !! + !! ! subroutine z_base_mlv_set_host(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_set_host @@ -1882,10 +2337,10 @@ contains !> Function base_mlv_set_dev: !! \memberof psb_z_base_multivect_type !! \brief Set_dev: base version is a no-op. - !! + !! ! subroutine z_base_mlv_set_dev(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_set_dev @@ -1894,10 +2349,10 @@ contains !> Function base_mlv_set_sync: !! \memberof psb_z_base_multivect_type !! \brief Set_sync: base version is a no-op. - !! + !! ! subroutine z_base_mlv_set_sync(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x end subroutine z_base_mlv_set_sync @@ -1906,10 +2361,10 @@ contains !> Function base_mlv_is_dev: !! \memberof psb_z_base_multivect_type !! \brief Is vector on external device . - !! + !! ! function z_base_mlv_is_dev(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x logical :: res @@ -1920,10 +2375,10 @@ contains !> Function base_mlv_is_host !! \memberof psb_z_base_multivect_type !! \brief Is vector on standard memory . - !! + !! ! function z_base_mlv_is_host(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x logical :: res @@ -1934,10 +2389,10 @@ contains !> Function base_mlv_is_sync !! \memberof psb_z_base_multivect_type !! \brief Is vector on sync . - !! + !! ! function z_base_mlv_is_sync(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x logical :: res @@ -1946,16 +2401,16 @@ contains ! - ! Size info. + ! Size info. ! ! !> Function base_mlv_get_nrows !! \memberof psb_z_base_multivect_type !! \brief Number of entries - !! + !! ! function z_base_mlv_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1965,7 +2420,7 @@ contains end function z_base_mlv_get_nrows function z_base_mlv_get_ncols(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_ipk_) :: res @@ -1978,10 +2433,10 @@ contains !> Function base_mlv_get_sizeof !! \memberof psb_z_base_multivect_type !! \brief Size in bytesa - !! + !! ! function z_base_mlv_sizeof(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(in) :: x integer(psb_epk_) :: res @@ -1994,10 +2449,10 @@ contains !> Function base_mlv_get_fmt !! \memberof psb_z_base_multivect_type !! \brief Format - !! + !! ! function z_base_mlv_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'BASE' end function z_base_mlv_get_fmt @@ -2010,18 +2465,18 @@ contains !! \memberof psb_z_base_multivect_type !! \brief Extract a copy of the contents !! - ! + ! function z_base_mlv_get_vect(x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), allocatable :: res(:,:) integer(psb_ipk_) :: info,m,n m = x%get_nrows() n = x%get_ncols() - if (.not.allocated(x%v)) return + if (.not.allocated(x%v)) return call x%sync() - allocate(res(m,n),stat=info) - if (info /= 0) then + allocate(res(m,n),stat=info) + if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') return end if @@ -2029,7 +2484,7 @@ contains end function z_base_mlv_get_vect ! - ! Reset all values + ! Reset all values ! ! !> Function base_mlv_set_scal @@ -2038,7 +2493,7 @@ contains !! \param val The value to set !! subroutine z_base_mlv_set_scal(x,val) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val @@ -2051,16 +2506,16 @@ contains !> Function base_mlv_set_vect !! \memberof psb_z_base_multivect_type !! \brief Set all entries - !! \param val(:) The vector to be copied in + !! \param val(:) The vector to be copied in !! subroutine z_base_mlv_set_vect(x,val) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_) :: nr, nc integer(psb_ipk_) :: info - if (allocated(x%v)) then + if (allocated(x%v)) then nr = min(size(x%v,1),size(val,1)) nc = min(size(x%v,2),size(val,2)) @@ -2072,8 +2527,8 @@ contains end subroutine z_base_mlv_set_vect ! - ! Dot products - ! + ! Dot products + ! ! !> Function base_mlv_dot_v !! \memberof psb_z_base_multivect_type @@ -2082,7 +2537,7 @@ contains !! \param y The other (base_mlv_vect) to be multiplied by !! function z_base_mlv_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_dpk_), allocatable :: res(:) @@ -2094,7 +2549,7 @@ contains ! ! Note: this is the base implementation. ! When we get here, we are sure that X is of - ! TYPE psb_z_base_mlv_vect (or its class does not care). + ! TYPE psb_z_base_mlv_vect (or its class does not care). ! If Y is not, throw the burden on it, implicitly ! calling dot_a ! @@ -2123,7 +2578,7 @@ contains !! \param y(:) The array to be multiplied by !! function z_base_mlv_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: y(:,:) integer(psb_ipk_), intent(in) :: n @@ -2141,7 +2596,7 @@ contains end function z_base_mlv_dot_a ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! ! @@ -2156,7 +2611,7 @@ contains !! subroutine z_base_mlv_axpby_v(m,alpha, x, beta, y, info, n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_z_base_multivect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: y @@ -2180,7 +2635,7 @@ contains end subroutine z_base_mlv_axpby_v ! - ! AXPBY is invoked via Y, hence the structure below. + ! AXPBY is invoked via Y, hence the structure below. ! ! !> Function base_mlv_axpby_a @@ -2194,7 +2649,7 @@ contains !! subroutine z_base_mlv_axpby_a(m,alpha, x, beta, y, info,n) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent(in) :: x(:,:) class(psb_z_base_multivect_type), intent(inout) :: y @@ -2230,10 +2685,10 @@ contains !! subroutine z_base_mlv_mlt_mv(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2243,10 +2698,10 @@ contains subroutine z_base_mlv_mlt_mv_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_z_base_vect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = 0 if (x%is_dev()) call x%sync() @@ -2263,7 +2718,7 @@ contains !! subroutine z_base_mlv_mlt_ar1(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:) class(psb_z_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2726,7 @@ contains info = 0 n = min(psb_size(y%v,1_psb_ipk_), size(x)) - do i=1, n + do i=1, n y%v(i,:) = y%v(i,:)*x(i) end do @@ -2286,7 +2741,7 @@ contains !! subroutine z_base_mlv_mlt_ar2(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:,:) class(psb_z_base_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -2313,7 +2768,7 @@ contains !! subroutine z_base_mlv_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:,:) complex(psb_dpk_), intent(in) :: x(:,:) @@ -2321,38 +2776,38 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, nr, nc - info = 0 + info = 0 nr = min(psb_size(z%v,1_psb_ipk_), size(x,1), size(y,1)) - nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) - if (alpha == zzero) then - if (beta == zone) then - return + nc = min(psb_size(z%v,2_psb_ipk_), size(x,2), size(y,2)) + if (alpha == zzero) then + if (beta == zone) then + return else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) end if else - if (alpha == zone) then - if (beta == zzero) then + if (alpha == zone) then + if (beta == zzero) then z%v(1:nr,1:nc) = y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == zone) then + else if (beta == zone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + y(1:nr,1:nc)*x(1:nr,1:nc) end if - else if (alpha == -zone) then - if (beta == zzero) then + else if (alpha == -zone) then + if (beta == zzero) then z%v(1:nr,1:nc) = -y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == zone) then + else if (beta == zone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) - y(1:nr,1:nc)*x(1:nr,1:nc) end if else - if (beta == zzero) then + if (beta == zzero) then z%v(1:nr,1:nc) = alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else if (beta == zone) then + else if (beta == zone) then z%v(1:nr,1:nc) = z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) - else + else z%v(1:nr,1:nc) = beta*z%v(1:nr,1:nc) + alpha*y(1:nr,1:nc)*x(1:nr,1:nc) end if end if @@ -2373,12 +2828,12 @@ contains subroutine z_base_mlv_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod use psb_string_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta class(psb_z_base_multivect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: y class(psb_z_base_multivect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n logical :: conjgx_, conjgy_ @@ -2389,7 +2844,7 @@ contains if (z%is_dev()) call z%sync() if (.not.psb_z_is_complex_) then call z%mlt(alpha,x%v,y%v,beta,info) - else + else conjgx_=.false. if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C') conjgy_=.false. @@ -2404,39 +2859,39 @@ contains !!$ !!$ subroutine z_base_mlv_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_base_multivect_type), intent(inout) :: y !!$ class(psb_z_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,x,y%v,beta,info) !!$ !!$ end subroutine z_base_mlv_mlt_av !!$ !!$ subroutine z_base_mlv_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ class(psb_z_base_multivect_type), intent(inout) :: x !!$ class(psb_z_base_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ call z%mlt(alpha,y,x,beta,info) !!$ !!$ end subroutine z_base_mlv_mlt_va !!$ !!$ ! - ! Simple scaling + ! Simple scaling ! !> Function base_mlv_scal !! \memberof psb_z_base_multivect_type @@ -2445,7 +2900,7 @@ contains !! subroutine z_base_mlv_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha @@ -2462,7 +2917,7 @@ contains !! \brief 2-norm |x(1:n)|_2 !! \param n how many entries to consider function z_base_mlv_nrm2(n,x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2484,7 +2939,7 @@ contains !! \brief infinity-norm |x(1:n)|_\infty !! \param n how many entries to consider function z_base_mlv_amax(n,x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2505,7 +2960,7 @@ contains !! \brief 1-norm |x(1:n)|_1 !! \param n how many entries to consider function z_base_mlv_asum(n,x) result(res) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_), allocatable :: res(:) @@ -2528,7 +2983,7 @@ contains !! \brief Set all entries to their respective absolute values. !! subroutine z_base_mlv_absval1(x) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x if (allocated(x%v)) then @@ -2540,13 +2995,13 @@ contains end subroutine z_base_mlv_absval1 subroutine z_base_mlv_absval2(x,y) - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x class(psb_z_base_multivect_type), intent(inout) :: y integer(psb_ipk_) :: info - + if (x%is_dev()) call x%sync() - if (allocated(x%v)) then + if (allocated(x%v)) then call y%axpby(min(x%get_nrows(),y%get_nrows()),zone,x,zzero,info) call y%absval() end if @@ -2555,15 +3010,15 @@ contains function z_base_mlv_use_buffer() result(res) - implicit none + implicit none logical :: res - + res = .true. end function z_base_mlv_use_buffer subroutine z_base_mlv_new_buffer(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2575,7 +3030,7 @@ contains subroutine z_base_mlv_new_comid(n,x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -2586,12 +3041,12 @@ contains subroutine z_base_mlv_maybe_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (psb_get_maybe_free_buffer())& & call x%free_buffer(info) @@ -2599,7 +3054,7 @@ contains subroutine z_base_mlv_free_buffer(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2609,7 +3064,7 @@ contains subroutine z_base_mlv_free_comid(x,info) use psb_realloc_mod - implicit none + implicit none class(psb_z_base_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -2632,7 +3087,7 @@ contains !! \param beta subroutine z_base_mlv_gthab(n,idx,alpha,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: alpha, beta, y(:) class(psb_z_base_multivect_type) :: x @@ -2648,7 +3103,7 @@ contains end subroutine z_base_mlv_gthab ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_z_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2657,7 +3112,7 @@ contains !! \param idx(:) indices subroutine z_base_mlv_gthzv_x(i,n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i,n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: y(:) @@ -2670,7 +3125,7 @@ contains ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_z_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2679,7 +3134,7 @@ contains !! \param idx(:) indices subroutine z_base_mlv_gthzv(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: y(:) class(psb_z_base_multivect_type) :: x @@ -2696,7 +3151,7 @@ contains end subroutine z_base_mlv_gthzv ! ! shortcut alpha=1 beta=0 - ! + ! !> Function base_mlv_gthzv !! \memberof psb_z_base_multivect_type !! \brief gather into an array special alpha=1 beta=0 @@ -2705,7 +3160,7 @@ contains !! \param idx(:) indices subroutine z_base_mlv_gthzm(n,idx,x,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: y(:,:) class(psb_z_base_multivect_type) :: x @@ -2722,17 +3177,17 @@ contains end subroutine z_base_mlv_gthzm ! - ! New comm internals impl. + ! New comm internals impl. ! subroutine z_base_mlv_gthzbuf(i,ixb,n,idx,x) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, ixb, n class(psb_i_base_vect_type) :: idx class(psb_z_base_multivect_type) :: x integer(psb_ipk_) :: nc - - if (.not.allocated(x%combuf)) then + + if (.not.allocated(x%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') return end if @@ -2744,9 +3199,9 @@ contains end subroutine z_base_mlv_gthzbuf ! - ! Scatter: + ! Scatter: ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) - ! + ! ! !> Function base_mlv_sctb !! \memberof psb_z_base_multivect_type @@ -2755,10 +3210,10 @@ contains !! \param n how many entries to consider !! \param idx(:) indices !! \param beta - !! \param x(:) + !! \param x(:) subroutine z_base_mlv_sctb(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:) class(psb_z_base_multivect_type) :: y @@ -2773,7 +3228,7 @@ contains subroutine z_base_mlv_sctbr2(n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: n, idx(:) complex(psb_dpk_) :: beta, x(:,:) class(psb_z_base_multivect_type) :: y @@ -2788,7 +3243,7 @@ contains subroutine z_base_mlv_sctb_x(i,n,idx,x,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, n class(psb_i_base_vect_type) :: idx complex( psb_dpk_) :: beta, x(:) @@ -2800,14 +3255,14 @@ contains subroutine z_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_) :: i, iyb, n class(psb_i_base_vect_type) :: idx complex(psb_dpk_) :: beta class(psb_z_base_multivect_type) :: y integer(psb_ipk_) :: nc - - if (.not.allocated(y%combuf)) then + + if (.not.allocated(y%combuf)) then call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') return end if @@ -2816,19 +3271,18 @@ contains nc = y%get_ncols() call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) call y%set_host() - + end subroutine z_base_mlv_sctb_buf ! !> Function base_device_wait: !! \memberof psb_z_base_vect_type !! \brief device_wait: base version is a no-op. - !! + !! ! subroutine z_base_mlv_device_wait() - implicit none - + implicit none + end subroutine z_base_mlv_device_wait end module psb_z_base_multivect_mod - diff --git a/base/modules/serial/psb_z_csc_mat_mod.f90 b/base/modules/serial/psb_z_csc_mat_mod.f90 index 67714cff9..222742ebe 100644 --- a/base/modules/serial/psb_z_csc_mat_mod.f90 +++ b/base/modules/serial/psb_z_csc_mat_mod.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_z_csc_mat_mod ! @@ -40,23 +40,23 @@ ! ! Please refere to psb_z_base_mat_mod for a detailed description ! of the various methods, and to psb_z_csc_impl for implementation details. -! +! module psb_z_csc_mat_mod use psb_z_base_mat_mod !> \namespace psb_base_mod \class psb_z_csc_sparse_mat !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat - !! + !! !! psb_z_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_z_base_sparse_mat) :: psb_z_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_ipk_), allocatable :: icp(:) !> Row indices. integer(psb_ipk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) contains @@ -107,16 +107,16 @@ module psb_z_csc_mat_mod !> \namespace psb_base_mod \class psb_z_csc_sparse_mat !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat - !! + !! !! psb_z_csc_sparse_mat type and the related methods. - !! + !! type, extends(psb_lz_base_sparse_mat) :: psb_lz_csc_sparse_mat - !> Pointers to beginning of cols in IA and VAL. + !> Pointers to beginning of cols in IA and VAL. integer(psb_lpk_), allocatable :: icp(:) !> Row indices. integer(psb_lpk_), allocatable :: ia(:) - !> Coefficient values. + !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) contains @@ -163,23 +163,23 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_z_csc_reallocate_nz(nz,a) + subroutine psb_z_csc_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_z_csc_sparse_mat), intent(inout) :: a end subroutine psb_z_csc_reallocate_nz end interface - + !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_z_csc_reinit(a,clear) import - class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_csc_reinit end interface - + !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -188,22 +188,22 @@ module psb_z_csc_mat_mod class(psb_z_csc_sparse_mat), intent(inout) :: a end subroutine psb_z_csc_trim end interface - + !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_z_csc_mold(a,b,info) + interface + subroutine psb_z_csc_mold(a,b,info) import class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csc_mold end interface - + !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -211,147 +211,147 @@ module psb_z_csc_mat_mod end subroutine psb_z_csc_allocate_mnnz end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_print interface subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_z_csc_print end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo - interface - subroutine psb_z_cp_csc_to_coo(a,b,info) + interface + subroutine psb_z_cp_csc_to_coo(a,b,info) import class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csc_to_coo end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo - interface - subroutine psb_z_cp_csc_from_coo(a,b,info) + interface + subroutine psb_z_cp_csc_from_coo(a,b,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csc_from_coo end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_to_fmt - interface - subroutine psb_z_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_z_cp_csc_to_fmt(a,b,info) import class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csc_to_fmt end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_fmt - interface - subroutine psb_z_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_z_cp_csc_from_fmt(a,b,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csc_from_fmt end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_to_coo - interface - subroutine psb_z_mv_csc_to_coo(a,b,info) + interface + subroutine psb_z_mv_csc_to_coo(a,b,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csc_to_coo end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo - interface - subroutine psb_z_mv_csc_from_coo(a,b,info) + interface + subroutine psb_z_mv_csc_from_coo(a,b,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csc_from_coo end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_to_fmt - interface - subroutine psb_z_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_z_mv_csc_to_fmt(a,b,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csc_to_fmt end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt - interface - subroutine psb_z_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_z_mv_csc_from_fmt(a,b,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_clean_zeros ! interface subroutine psb_z_csc_clean_zeros(a, info) - import + import class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csc_clean_zeros end interface - - + + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from - interface + interface subroutine psb_z_csc_cp_from(a,b) import class(psb_z_csc_sparse_mat), intent(inout) :: a type(psb_z_csc_sparse_mat), intent(in) :: b end subroutine psb_z_csc_cp_from end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from - interface + interface subroutine psb_z_csc_mv_from(a,b) import class(psb_z_csc_sparse_mat), intent(inout) :: a type(psb_z_csc_sparse_mat), intent(inout) :: b end subroutine psb_z_csc_mv_from end interface - - + + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csput_a - interface - subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -360,10 +360,10 @@ module psb_z_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csc_csput_a end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -378,10 +378,10 @@ module psb_z_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_csc_csgetptn end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csgetrow - interface + interface subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ @@ -400,7 +400,7 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csgetblk - interface + interface subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) import @@ -414,11 +414,11 @@ module psb_z_csc_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_csc_csgetblk end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssv - interface - subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -429,8 +429,8 @@ module psb_z_csc_mat_mod end interface !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssm - interface - subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -439,11 +439,11 @@ module psb_z_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_csc_cssm end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csmv - interface - subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -455,8 +455,8 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csmm - interface - subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -465,21 +465,21 @@ module psb_z_csc_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_csc_csmm end interface - - + + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_maxval - interface + interface function psb_z_csc_maxval(a) result(res) import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csc_maxval end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csnm1 - interface + interface function psb_z_csc_csnm1(a) result(res) import class(psb_z_csc_sparse_mat), intent(in) :: a @@ -489,8 +489,8 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_rowsum - interface - subroutine psb_z_csc_rowsum(d,a) + interface + subroutine psb_z_csc_rowsum(d,a) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -499,18 +499,18 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_arwsum - interface - subroutine psb_z_csc_arwsum(d,a) + interface + subroutine psb_z_csc_arwsum(d,a) import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csc_arwsum end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_colsum - interface - subroutine psb_z_csc_colsum(d,a) + interface + subroutine psb_z_csc_colsum(d,a) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -519,29 +519,29 @@ module psb_z_csc_mat_mod !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_aclsum - interface - subroutine psb_z_csc_aclsum(d,a) + interface + subroutine psb_z_csc_aclsum(d,a) import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csc_aclsum end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_get_diag - interface - subroutine psb_z_csc_get_diag(a,d,info) + interface + subroutine psb_z_csc_get_diag(a,d,info) import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csc_get_diag end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scal - interface - subroutine psb_z_csc_scal(d,a,info,side) + interface + subroutine psb_z_csc_scal(d,a,info,side) import class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) @@ -549,42 +549,41 @@ module psb_z_csc_mat_mod character, intent(in), optional :: side end subroutine psb_z_csc_scal end interface - + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scals interface - subroutine psb_z_csc_scals(d,a,info) + subroutine psb_z_csc_scals(d,a,info) import class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csc_scals end interface - ! ! lz - ! + ! !> \memberof psb_lz_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_lz_csc_reallocate_nz(nz,a) + subroutine psb_lz_csc_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_lz_csc_sparse_mat), intent(inout) :: a end subroutine psb_lz_csc_reallocate_nz end interface - + !> \memberof psb_lz_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_lz_csc_reinit(a,clear) import - class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lz_csc_reinit end interface - + !> \memberof psb_lz_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -593,22 +592,22 @@ module psb_z_csc_mat_mod class(psb_lz_csc_sparse_mat), intent(inout) :: a end subroutine psb_lz_csc_trim end interface - + !> \memberof psb_lz_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lz_csc_mold(a,b,info) + interface + subroutine psb_lz_csc_mold(a,b,info) import class(psb_lz_csc_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csc_mold end interface - + !> \memberof psb_lz_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) + subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_lz_csc_sparse_mat), intent(inout) :: a @@ -616,146 +615,146 @@ module psb_z_csc_mat_mod end subroutine psb_lz_csc_allocate_mnnz end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_print interface subroutine psb_lz_csc_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lz_csc_print end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo - interface - subroutine psb_lz_cp_csc_to_coo(a,b,info) + interface + subroutine psb_lz_cp_csc_to_coo(a,b,info) import class(psb_lz_csc_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csc_to_coo end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo - interface - subroutine psb_lz_cp_csc_from_coo(a,b,info) + interface + subroutine psb_lz_cp_csc_from_coo(a,b,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csc_from_coo end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_fmt - interface - subroutine psb_lz_cp_csc_to_fmt(a,b,info) + interface + subroutine psb_lz_cp_csc_to_fmt(a,b,info) import class(psb_lz_csc_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csc_to_fmt end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt - interface - subroutine psb_lz_cp_csc_from_fmt(a,b,info) + interface + subroutine psb_lz_cp_csc_from_fmt(a,b,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csc_from_fmt end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo - interface - subroutine psb_lz_mv_csc_to_coo(a,b,info) + interface + subroutine psb_lz_mv_csc_to_coo(a,b,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csc_to_coo end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo - interface - subroutine psb_lz_mv_csc_from_coo(a,b,info) + interface + subroutine psb_lz_mv_csc_from_coo(a,b,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csc_from_coo end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt - interface - subroutine psb_lz_mv_csc_to_fmt(a,b,info) + interface + subroutine psb_lz_mv_csc_to_fmt(a,b,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csc_to_fmt end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt - interface - subroutine psb_lz_mv_csc_from_fmt(a,b,info) + interface + subroutine psb_lz_mv_csc_from_fmt(a,b,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csc_from_fmt end interface - + ! - !> + !> !! \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros ! interface subroutine psb_lz_csc_clean_zeros(a, info) - import + import class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csc_clean_zeros end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from - interface + interface subroutine psb_lz_csc_cp_from(a,b) import class(psb_lz_csc_sparse_mat), intent(inout) :: a type(psb_lz_csc_sparse_mat), intent(in) :: b end subroutine psb_lz_csc_cp_from end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from - interface + interface subroutine psb_lz_csc_mv_from(a,b) import class(psb_lz_csc_sparse_mat), intent(inout) :: a type(psb_lz_csc_sparse_mat), intent(inout) :: b end subroutine psb_lz_csc_mv_from end interface - - + + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a - interface - subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -764,10 +763,10 @@ module psb_z_csc_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csc_csput_a end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_lz_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -782,10 +781,10 @@ module psb_z_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csc_csgetptn end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow - interface + interface subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -804,7 +803,7 @@ module psb_z_csc_mat_mod !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_csgetblk - interface + interface subroutine psb_lz_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import @@ -818,31 +817,31 @@ module psb_z_csc_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csc_csgetblk end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag - interface - subroutine psb_lz_csc_get_diag(a,d,info) + interface + subroutine psb_lz_csc_get_diag(a,d,info) import class(psb_lz_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csc_get_diag end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_maxval - interface + interface function psb_lz_csc_maxval(a) result(res) import class(psb_lz_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_csc_maxval end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_csnm1 - interface + interface function psb_lz_csc_csnm1(a) result(res) import class(psb_lz_csc_sparse_mat), intent(in) :: a @@ -852,8 +851,8 @@ module psb_z_csc_mat_mod !> \memberof psb_lz_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_rowsum - interface - subroutine psb_lz_csc_rowsum(d,a) + interface + subroutine psb_lz_csc_rowsum(d,a) import class(psb_lz_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -862,18 +861,18 @@ module psb_z_csc_mat_mod !> \memberof psb_lz_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_arwsum - interface - subroutine psb_lz_csc_arwsum(d,a) + interface + subroutine psb_lz_csc_arwsum(d,a) import class(psb_lz_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_csc_arwsum end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_colsum - interface - subroutine psb_lz_csc_colsum(d,a) + interface + subroutine psb_lz_csc_colsum(d,a) import class(psb_lz_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -882,18 +881,18 @@ module psb_z_csc_mat_mod !> \memberof psb_lz_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_aclsum - interface - subroutine psb_lz_csc_aclsum(d,a) + interface + subroutine psb_lz_csc_aclsum(d,a) import class(psb_lz_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_csc_aclsum end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scal - interface - subroutine psb_lz_csc_scal(d,a,info,side) + interface + subroutine psb_lz_csc_scal(d,a,info,side) import class(psb_lz_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) @@ -901,27 +900,25 @@ module psb_z_csc_mat_mod character, intent(in), optional :: side end subroutine psb_lz_csc_scal end interface - + !> \memberof psb_lz_csc_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scals interface - subroutine psb_lz_csc_scals(d,a,info) + subroutine psb_lz_csc_scals(d,a,info) import class(psb_lz_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csc_scals end interface - - -contains +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -929,54 +926,54 @@ contains ! ! == =================================== - + function z_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function z_csc_is_by_cols - + function z_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%icp) res = res + psb_sizeof_ip * psb_size(a%ia) - + end function z_csc_sizeof function z_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function z_csc_get_fmt - + function z_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%icp(a%get_ncols()+1)-1 end function z_csc_get_nzeros function z_csc_get_size(a) result(res) - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -988,17 +985,17 @@ contains function z_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function z_csc_get_nz_col @@ -1013,11 +1010,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine z_csc_free(a) - implicit none + subroutine z_csc_free(a) + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a @@ -1027,7 +1024,7 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine z_csc_free @@ -1038,7 +1035,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1046,57 +1043,57 @@ contains ! ! == =================================== - + function lz_csc_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function lz_csc_is_by_cols ! ! lz ! - + function lz_csc_sizeof(a) result(res) - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2*psb_sizeof_lp res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%icp) res = res + psb_sizeof_lp * psb_size(a%ia) - + end function lz_csc_sizeof function lz_csc_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSC' end function lz_csc_get_fmt - + function lz_csc_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%icp(a%get_ncols()+1)-1 end function lz_csc_get_nzeros function lz_csc_get_size(a) result(res) - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ia)) then + + if (allocated(a%ia)) then res = size(a%ia) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1108,17 +1105,17 @@ contains function lz_csc_get_nz_col(idx,a) result(res) use psb_const_mod implicit none - + class(psb_lz_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_ncols())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then res = a%icp(idx+1)-a%icp(idx) end if - + end function lz_csc_get_nz_col @@ -1133,11 +1130,11 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine lz_csc_free(a) - implicit none + subroutine lz_csc_free(a) + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a @@ -1147,7 +1144,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine lz_csc_free diff --git a/base/modules/serial/psb_z_csr_mat_mod.f90 b/base/modules/serial/psb_z_csr_mat_mod.f90 index b8267ac62..4ec8dd004 100644 --- a/base/modules/serial/psb_z_csr_mat_mod.f90 +++ b/base/modules/serial/psb_z_csr_mat_mod.f90 @@ -1,10 +1,10 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -16,7 +16,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -28,8 +28,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_z_csr_mat_mod ! @@ -48,17 +48,17 @@ module psb_z_csr_mat_mod !> \namespace psb_base_mod \class psb_z_csr_sparse_mat !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat - !! + !! !! psb_z_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_z_base_sparse_mat) :: psb_z_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_ipk_), allocatable :: irp(:) !> Column indices. integer(psb_ipk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) contains @@ -112,23 +112,23 @@ module psb_z_csr_mat_mod !> \memberof psb_z_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_z_csr_reallocate_nz(nz,a) + subroutine psb_z_csr_reallocate_nz(nz,a) import integer(psb_ipk_), intent(in) :: nz class(psb_z_csr_sparse_mat), intent(inout) :: a end subroutine psb_z_csr_reallocate_nz end interface - + !> \memberof psb_z_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_z_csr_reinit(a,clear) import - class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_csr_reinit end interface - + !> \memberof psb_z_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -138,22 +138,22 @@ module psb_z_csr_mat_mod end subroutine psb_z_csr_trim end interface - + !> \memberof psb_z_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_z_csr_mold(a,b,info) + interface + subroutine psb_z_csr_mold(a,b,info) import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csr_mold end interface - + !> \memberof psb_z_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) import integer(psb_ipk_), intent(in) :: m,n class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -161,14 +161,14 @@ module psb_z_csr_mat_mod end subroutine psb_z_csr_allocate_mnnz end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_print interface subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -187,27 +187,27 @@ module psb_z_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_z_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -216,13 +216,13 @@ module psb_z_csr_mat_mod class(psb_z_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_z_csr_tril end interface - + ! !> Function triu: !! \memberof psb_z_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -231,27 +231,27 @@ module psb_z_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_z_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -260,133 +260,133 @@ module psb_z_csr_mat_mod class(psb_z_coo_sparse_mat), optional, intent(out) :: l end subroutine psb_z_csr_triu end interface - + ! - !> + !> !! \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_clean_zeros ! interface subroutine psb_z_csr_clean_zeros(a, info) - import + import class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csr_clean_zeros end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo - interface - subroutine psb_z_cp_csr_to_coo(a,b,info) + interface + subroutine psb_z_cp_csr_to_coo(a,b,info) import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csr_to_coo end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo - interface - subroutine psb_z_cp_csr_from_coo(a,b,info) + interface + subroutine psb_z_cp_csr_from_coo(a,b,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csr_from_coo end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_to_fmt - interface - subroutine psb_z_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_z_cp_csr_to_fmt(a,b,info) import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csr_to_fmt end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from_fmt - interface - subroutine psb_z_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_z_cp_csr_from_fmt(a,b,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csr_from_fmt end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_to_coo - interface - subroutine psb_z_mv_csr_to_coo(a,b,info) + interface + subroutine psb_z_mv_csr_to_coo(a,b,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csr_to_coo end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo - interface - subroutine psb_z_mv_csr_from_coo(a,b,info) + interface + subroutine psb_z_mv_csr_from_coo(a,b,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csr_from_coo end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_to_fmt - interface - subroutine psb_z_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_z_mv_csr_to_fmt(a,b,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csr_to_fmt end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt - interface - subroutine psb_z_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_z_mv_csr_from_fmt(a,b,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_mv_csr_from_fmt end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cp_from - interface + interface subroutine psb_z_csr_cp_from(a,b) import class(psb_z_csr_sparse_mat), intent(inout) :: a type(psb_z_csr_sparse_mat), intent(in) :: b end subroutine psb_z_csr_cp_from end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_mv_from - interface + interface subroutine psb_z_csr_mv_from(a,b) import class(psb_z_csr_sparse_mat), intent(inout) :: a type(psb_z_csr_sparse_mat), intent(inout) :: b end subroutine psb_z_csr_mv_from end interface - - + + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csput_a - interface - subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -395,10 +395,10 @@ module psb_z_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csr_csput_a end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -413,10 +413,10 @@ module psb_z_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_csr_csgetptn end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csgetrow - interface + interface subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) import @@ -435,8 +435,8 @@ module psb_z_csr_mat_mod !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssv - interface - subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -447,8 +447,8 @@ module psb_z_csr_mat_mod end interface !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssm - interface - subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -457,11 +457,11 @@ module psb_z_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_csr_cssm end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csmv - interface - subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -473,8 +473,8 @@ module psb_z_csr_mat_mod !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csmm - interface - subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) + interface + subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -483,32 +483,32 @@ module psb_z_csr_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_csr_csmm end interface - - + + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_maxval - interface + interface function psb_z_csr_maxval(a) result(res) import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csr_maxval end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_csnmi - interface + interface function psb_z_csr_csnmi(a) result(res) import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csr_csnmi end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_rowsum - interface - subroutine psb_z_csr_rowsum(d,a) + interface + subroutine psb_z_csr_rowsum(d,a) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -517,18 +517,18 @@ module psb_z_csr_mat_mod !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_arwsum - interface - subroutine psb_z_csr_arwsum(d,a) + interface + subroutine psb_z_csr_arwsum(d,a) import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csr_arwsum end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_colsum - interface - subroutine psb_z_csr_colsum(d,a) + interface + subroutine psb_z_csr_colsum(d,a) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -537,29 +537,29 @@ module psb_z_csr_mat_mod !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_aclsum - interface - subroutine psb_z_csr_aclsum(d,a) + interface + subroutine psb_z_csr_aclsum(d,a) import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csr_aclsum end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_get_diag - interface - subroutine psb_z_csr_get_diag(a,d,info) + interface + subroutine psb_z_csr_get_diag(a,d,info) import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csr_get_diag end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scal - interface - subroutine psb_z_csr_scal(d,a,info,side) + interface + subroutine psb_z_csr_scal(d,a,info,side) import class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) @@ -567,32 +567,31 @@ module psb_z_csr_mat_mod character, intent(in), optional :: side end subroutine psb_z_csr_scal end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_scals interface - subroutine psb_z_csr_scals(d,a,info) + subroutine psb_z_csr_scals(d,a,info) import class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csr_scals end interface - !> \namespace psb_base_mod \class psb_lz_csr_sparse_mat !! \extends psb_lz_base_mat_mod::psb_lz_base_sparse_mat - !! + !! !! psb_lz_csr_sparse_mat type and the related methods. !! This is a very common storage type, and is the default for assembled !! matrices in our library type, extends(psb_lz_base_sparse_mat) :: psb_lz_csr_sparse_mat - !> Pointers to beginning of rows in JA and VAL. + !> Pointers to beginning of rows in JA and VAL. integer(psb_lpk_), allocatable :: irp(:) !> Column indices. integer(psb_lpk_), allocatable :: ja(:) - !> Coefficient values. + !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) contains @@ -642,23 +641,23 @@ module psb_z_csr_mat_mod !> \memberof psb_lz_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface - subroutine psb_lz_csr_reallocate_nz(nz,a) + subroutine psb_lz_csr_reallocate_nz(nz,a) import integer(psb_lpk_), intent(in) :: nz class(psb_lz_csr_sparse_mat), intent(inout) :: a end subroutine psb_lz_csr_reallocate_nz end interface - + !> \memberof psb_lz_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_reinit - interface + interface subroutine psb_lz_csr_reinit(a,clear) import - class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lz_csr_reinit end interface - + !> \memberof psb_lz_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_trim interface @@ -668,22 +667,22 @@ module psb_z_csr_mat_mod end subroutine psb_lz_csr_trim end interface - + !> \memberof psb_lz_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_mold - interface - subroutine psb_lz_csr_mold(a,b,info) + interface + subroutine psb_lz_csr_mold(a,b,info) import class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csr_mold end interface - + !> \memberof psb_lz_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface - subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) + subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) import integer(psb_lpk_), intent(in) :: m,n class(psb_lz_csr_sparse_mat), intent(inout) :: a @@ -691,14 +690,14 @@ module psb_z_csr_mat_mod end subroutine psb_lz_csr_allocate_mnnz end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_print interface subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) import integer(psb_ipk_), intent(in) :: iout - class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -717,27 +716,27 @@ module psb_z_csr_mat_mod !! Moreover, apply a clipping by copying entries A(I,J) only if !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX - !! + !! !! \param l the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param u [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lz_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import + import class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -746,13 +745,13 @@ module psb_z_csr_mat_mod class(psb_lz_coo_sparse_mat), optional, intent(out) :: u end subroutine psb_lz_csr_tril end interface - + ! !> Function triu: !! \memberof psb_z_csr_sparse_mat !! \brief Copy the upper triangle, i.e. all entries !! A(I,J) such that DIAG <= J-I - !! default value is DIAG=0, i.e. upper triangle from + !! default value is DIAG=0, i.e. upper triangle from !! the main diagonal up. !! DIAG= 1 means copy the strictly upper triangle !! DIAG=-1 means copy the upper triangle plus the first diagonal @@ -761,27 +760,27 @@ module psb_z_csr_mat_mod !! IMIN<=I<=IMAX !! JMIN<=J<=JMAX !! Optionally copies the lower triangle at the same time - !! + !! !! \param u the output (sub)matrix !! \param info return code !! \param diag [0] the last diagonal (J-I) to be considered. - !! \param imin [1] the minimum row index we are interested in - !! \param imax [a\%get_nrows()] the minimum row index we are interested in - !! \param jmin [1] minimum col index - !! \param jmax [a\%get_ncols()] maximum col index + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] !! ( iren cannot be specified with rscale/cscale) - !! \param append [false] append to ia,ja + !! \param append [false] append to ia,ja !! \param nzin [none] if append, then first new entry should go in entry nzin+1 !! \param l [none] copy of the complementary triangle - !! + !! ! - interface + interface subroutine psb_lz_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import + import class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -792,133 +791,133 @@ module psb_z_csr_mat_mod end interface ! - !> + !> !! \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros ! interface subroutine psb_lz_csr_clean_zeros(a, info) - import + import class(psb_lz_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csr_clean_zeros end interface - - + + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo - interface - subroutine psb_lz_cp_csr_to_coo(a,b,info) + interface + subroutine psb_lz_cp_csr_to_coo(a,b,info) import class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csr_to_coo end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo - interface - subroutine psb_lz_cp_csr_from_coo(a,b,info) + interface + subroutine psb_lz_cp_csr_from_coo(a,b,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csr_from_coo end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_fmt - interface - subroutine psb_lz_cp_csr_to_fmt(a,b,info) + interface + subroutine psb_lz_cp_csr_to_fmt(a,b,info) import class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csr_to_fmt end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt - interface - subroutine psb_lz_cp_csr_from_fmt(a,b,info) + interface + subroutine psb_lz_cp_csr_from_fmt(a,b,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_cp_csr_from_fmt end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo - interface - subroutine psb_lz_mv_csr_to_coo(a,b,info) + interface + subroutine psb_lz_mv_csr_to_coo(a,b,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csr_to_coo end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo - interface - subroutine psb_lz_mv_csr_from_coo(a,b,info) + interface + subroutine psb_lz_mv_csr_from_coo(a,b,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csr_from_coo end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt - interface - subroutine psb_lz_mv_csr_to_fmt(a,b,info) + interface + subroutine psb_lz_mv_csr_to_fmt(a,b,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csr_to_fmt end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt - interface - subroutine psb_lz_mv_csr_from_fmt(a,b,info) + interface + subroutine psb_lz_mv_csr_from_fmt(a,b,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_mv_csr_from_fmt end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from - interface + interface subroutine psb_lz_csr_cp_from(a,b) import class(psb_lz_csr_sparse_mat), intent(inout) :: a type(psb_lz_csr_sparse_mat), intent(in) :: b end subroutine psb_lz_csr_cp_from end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from - interface + interface subroutine psb_lz_csr_mv_from(a,b) import class(psb_lz_csr_sparse_mat), intent(inout) :: a type(psb_lz_csr_sparse_mat), intent(inout) :: b end subroutine psb_lz_csr_mv_from end interface - - + + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a - interface - subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + interface + subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -927,10 +926,10 @@ module psb_z_csr_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csr_csput_a end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_base_mat_mod::psb_base_csgetptn - interface + interface subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -945,10 +944,10 @@ module psb_z_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csr_csgetptn end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow - interface + interface subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import @@ -964,11 +963,11 @@ module psb_z_csr_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csr_csgetrow end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag - interface - subroutine psb_lz_csr_get_diag(a,d,info) + interface + subroutine psb_lz_csr_get_diag(a,d,info) import class(psb_lz_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -978,8 +977,8 @@ module psb_z_csr_mat_mod !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scal - interface - subroutine psb_lz_csr_scal(d,a,info,side) + interface + subroutine psb_lz_csr_scal(d,a,info,side) import class(psb_lz_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) @@ -987,42 +986,42 @@ module psb_z_csr_mat_mod character, intent(in), optional :: side end subroutine psb_lz_csr_scal end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_lz_base_mat_mod::psb_lz_base_scals interface - subroutine psb_lz_csr_scals(d,a,info) + subroutine psb_lz_csr_scals(d,a,info) import class(psb_lz_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csr_scals end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_maxval - interface + interface function psb_lz_csr_maxval(a) result(res) import class(psb_lz_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_csr_maxval end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_csnmi - interface + interface function psb_lz_csr_csnmi(a) result(res) import class(psb_lz_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_csr_csnmi end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_rowsum - interface - subroutine psb_lz_csr_rowsum(d,a) + interface + subroutine psb_lz_csr_rowsum(d,a) import class(psb_lz_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -1031,18 +1030,18 @@ module psb_z_csr_mat_mod !> \memberof psb_lz_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_arwsum - interface - subroutine psb_lz_csr_arwsum(d,a) + interface + subroutine psb_lz_csr_arwsum(d,a) import class(psb_lz_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_csr_arwsum end interface - + !> \memberof psb_lz_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_colsum - interface - subroutine psb_lz_csr_colsum(d,a) + interface + subroutine psb_lz_csr_colsum(d,a) import class(psb_lz_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) @@ -1051,22 +1050,22 @@ module psb_z_csr_mat_mod !> \memberof psb_lz_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_lz_base_aclsum - interface - subroutine psb_lz_csr_aclsum(d,a) + interface + subroutine psb_lz_csr_aclsum(d,a) import class(psb_lz_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_lz_csr_aclsum end interface - -contains + +contains ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1075,54 +1074,54 @@ contains ! == =================================== - + function z_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function z_csr_is_by_rows - + function z_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_ip * psb_size(a%irp) res = res + psb_sizeof_ip * psb_size(a%ja) - + end function z_csr_sizeof function z_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function z_csr_get_fmt - + function z_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = a%irp(a%get_nrows()+1)-1 end function z_csr_get_nzeros function z_csr_get_size(a) result(res) - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1134,17 +1133,17 @@ contains function z_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function z_csr_get_nz_row @@ -1159,10 +1158,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine z_csr_free(a) - implicit none + subroutine z_csr_free(a) + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a @@ -1172,18 +1171,18 @@ contains call a%set_null() call a%set_nrows(0_psb_ipk_) call a%set_ncols(0_psb_ipk_) - + return end subroutine z_csr_free - + ! == =================================== ! ! ! - ! Getters + ! Getters ! ! ! @@ -1192,54 +1191,54 @@ contains ! == =================================== - + function lz_csr_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a logical :: res res = .true. - + end function lz_csr_is_by_rows - + function lz_csr_sizeof(a) result(res) - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a integer(psb_epk_) :: res - res = 2 * psb_sizeof_lp + res = 2 * psb_sizeof_lp res = res + (2*psb_sizeof_dp) * psb_size(a%val) res = res + psb_sizeof_lp * psb_size(a%irp) res = res + psb_sizeof_lp * psb_size(a%ja) - + end function lz_csr_sizeof function lz_csr_get_fmt() result(res) - implicit none + implicit none character(len=5) :: res res = 'CSR' end function lz_csr_get_fmt - + function lz_csr_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = a%irp(a%get_nrows()+1)-1 end function lz_csr_get_nzeros function lz_csr_get_size(a) result(res) - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a integer(psb_lpk_) :: res res = -1 - - if (allocated(a%ja)) then + + if (allocated(a%ja)) then res = size(a%ja) end if - if (allocated(a%val)) then - if (res >= 0) then + if (allocated(a%val)) then + if (res >= 0) then res = min(res,size(a%val)) - else + else res = size(a%val) end if end if @@ -1251,17 +1250,17 @@ contains function lz_csr_get_nz_row(idx,a) result(res) implicit none - + class(psb_lz_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in) :: idx integer(psb_lpk_) :: res - - res = 0 - - if ((1<=idx).and.(idx<=a%get_nrows())) then + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then res = a%irp(idx+1)-a%irp(idx) end if - + end function lz_csr_get_nz_row @@ -1276,10 +1275,10 @@ contains ! ! ! - ! == =================================== + ! == =================================== - subroutine lz_csr_free(a) - implicit none + subroutine lz_csr_free(a) + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a @@ -1289,7 +1288,7 @@ contains call a%set_null() call a%set_nrows(0_psb_lpk_) call a%set_ncols(0_psb_lpk_) - + return end subroutine lz_csr_free diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 index ed4558266..35586b3e3 100644 --- a/base/modules/serial/psb_z_mat_mod.F90 +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_z_mat_mod ! @@ -37,7 +37,7 @@ ! provide a mean of switching, at run-time, among different formats, ! potentially unknown at the library compile-time by adding a layer of ! indirection. This type encapsulates the psb_z_base_sparse_mat class -! inside another class which is the one visible to the user. +! inside another class which is the one visible to the user. ! Most methods of the psb_z_mat_mod simply call the methods of the ! encapsulated class. ! The exceptions are mainly cscnv and cp_from/cp_to; these provide @@ -48,14 +48,14 @@ ! through the application life. ! In particular, computational methods can only be invoked when ! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the ! following state transition table. Associated with these states are ! the possible dynamic types of the inner matrix object. ! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method !| ---------------------------------- !| Null Build csall !| Build Build csput @@ -64,7 +64,7 @@ !| Assembled Update reinit !| Update Update csput !| Update Assembled cscnv -!| * unchanged reall +!| * unchanged reall !| Assembled Null free ! ! @@ -74,7 +74,7 @@ ! of the indices, which are PSB_LPK_ so that the entries ! are guaranteed to be able to contain global indices. ! This type only supports data handling and preprocessing, it is -! not supposed to be used for computations. +! not supposed to be used for computations. ! module psb_z_mat_mod @@ -84,7 +84,7 @@ module psb_z_mat_mod type :: psb_zspmat_type - class(psb_z_base_sparse_mat), allocatable :: a + class(psb_z_base_sparse_mat), allocatable :: a contains ! Getters @@ -126,12 +126,12 @@ module psb_z_mat_mod procedure, pass(a) :: set_unit => psb_z_set_unit procedure, pass(a) :: set_repeatable_updates => psb_z_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_z_csall procedure, pass(a) :: free => psb_z_free procedure, pass(a) :: trim => psb_z_trim procedure, pass(a) :: csput_a => psb_z_csput_a - procedure, pass(a) :: csput_v => psb_z_csput_v + procedure, pass(a) :: csput_v => psb_z_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_z_csgetptn procedure, pass(a) :: csgetrow => psb_z_csgetrow @@ -141,7 +141,7 @@ module psb_z_mat_mod procedure, pass(a) :: lcsgetptn => psb_z_lcsgetptn procedure, pass(a) :: lcsgetrow => psb_z_lcsgetrow generic, public :: csget => lcsgetptn, lcsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_z_tril procedure, pass(a) :: triu => psb_z_triu procedure, pass(a) :: m_csclip => psb_z_csclip @@ -169,7 +169,7 @@ module psb_z_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => z_mat_sync procedure, pass(a) :: is_host => z_mat_is_host @@ -205,16 +205,16 @@ module psb_z_mat_mod procedure, pass(a) :: mv_to_lb => psb_z_mv_to_lb procedure, pass(a) :: cp_from_lb => psb_z_cp_from_lb procedure, pass(a) :: cp_to_lb => psb_z_cp_to_lb - procedure, pass(a) :: mv_from_l => psb_z_mv_from_l - procedure, pass(a) :: mv_to_l => psb_z_mv_to_l - procedure, pass(a) :: cp_from_l => psb_z_cp_from_l - procedure, pass(a) :: cp_to_l => psb_z_cp_to_l + procedure, pass(a) :: mv_from_l => psb_z_mv_from_l + procedure, pass(a) :: mv_to_l => psb_z_mv_to_l + procedure, pass(a) :: cp_from_l => psb_z_cp_from_l + procedure, pass(a) :: cp_to_l => psb_z_cp_to_l generic, public :: mv_from => mv_from_lb, mv_from_l generic, public :: mv_to => mv_to_lb, mv_to_l generic, public :: cp_from => cp_from_lb, cp_from_l generic, public :: cp_to => cp_to_lb, cp_to_l - - ! Computational routines + + ! Computational routines procedure, pass(a) :: get_diag => psb_z_get_diag procedure, pass(a) :: maxval => psb_z_maxval procedure, pass(a) :: spnmi => psb_z_csnmi @@ -234,6 +234,11 @@ module psb_z_mat_mod procedure, pass(a) :: cssv => psb_z_cssv procedure, pass(a) :: cssm => psb_z_cssm generic, public :: spsm => cssm, cssv, cssv_v + procedure, pass(a) :: scalpid => psb_z_scalplusidentity + procedure, pass(a) :: spaxpby => psb_z_spaxpby + procedure, pass(a) :: cmpval => psb_z_cmpval + procedure, pass(a) :: cmpmat => psb_z_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_zspmat_type @@ -267,7 +272,7 @@ module psb_z_mat_mod type :: psb_lzspmat_type - class(psb_lz_base_sparse_mat), allocatable :: a + class(psb_lz_base_sparse_mat), allocatable :: a contains ! Getters @@ -296,7 +301,7 @@ module psb_z_mat_mod ! Setters procedure, pass(a) :: set_lnrows => psb_lz_set_lnrows procedure, pass(a) :: set_lncols => psb_lz_set_lncols -#if defined(IPK4) && defined(LPK8) +#if defined(IPK4) && defined(LPK8) procedure, pass(a) :: set_inrows => psb_lz_set_inrows procedure, pass(a) :: set_incols => psb_lz_set_incols generic, public :: set_nrows => set_inrows, set_lnrows @@ -305,7 +310,7 @@ module psb_z_mat_mod generic, public :: set_nrows => set_lnrows generic, public :: set_ncols => set_lncols #endif - + procedure, pass(a) :: set_dupl => psb_lz_set_dupl procedure, pass(a) :: set_null => psb_lz_set_null procedure, pass(a) :: set_bld => psb_lz_set_bld @@ -319,12 +324,12 @@ module psb_z_mat_mod procedure, pass(a) :: set_unit => psb_lz_set_unit procedure, pass(a) :: set_repeatable_updates => psb_lz_set_repeatable_updates - ! Memory/data management + ! Memory/data management procedure, pass(a) :: csall => psb_lz_csall procedure, pass(a) :: free => psb_lz_free procedure, pass(a) :: trim => psb_lz_trim procedure, pass(a) :: csput_a => psb_lz_csput_a - procedure, pass(a) :: csput_v => psb_lz_csput_v + procedure, pass(a) :: csput_v => psb_lz_csput_v generic, public :: csput => csput_a, csput_v procedure, pass(a) :: csgetptn => psb_lz_csgetptn procedure, pass(a) :: csgetrow => psb_lz_csgetrow @@ -334,7 +339,7 @@ module psb_z_mat_mod !!$ procedure, pass(a) :: icsgetptn => psb_lz_icsgetptn !!$ procedure, pass(a) :: icsgetrow => psb_lz_icsgetrow !!$ generic, public :: csget => icsgetptn, icsgetrow -#endif +#endif procedure, pass(a) :: tril => psb_lz_tril procedure, pass(a) :: triu => psb_lz_triu procedure, pass(a) :: m_csclip => psb_lz_csclip @@ -362,7 +367,7 @@ module psb_z_mat_mod ! Any derived class having extra storage upon sync ! will guarantee that both fortran/host side and ! external side contain the same data. The base - ! version is only a placeholder. + ! version is only a placeholder. ! procedure, pass(a) :: sync => lz_mat_sync procedure, pass(a) :: is_host => lz_mat_is_host @@ -398,16 +403,16 @@ module psb_z_mat_mod procedure, pass(a) :: mv_to_ib => psb_lz_mv_to_ib procedure, pass(a) :: cp_from_ib => psb_lz_cp_from_ib procedure, pass(a) :: cp_to_ib => psb_lz_cp_to_ib - procedure, pass(a) :: mv_from_i => psb_lz_mv_from_i - procedure, pass(a) :: mv_to_i => psb_lz_mv_to_i - procedure, pass(a) :: cp_from_i => psb_lz_cp_from_i - procedure, pass(a) :: cp_to_i => psb_lz_cp_to_i + procedure, pass(a) :: mv_from_i => psb_lz_mv_from_i + procedure, pass(a) :: mv_to_i => psb_lz_mv_to_i + procedure, pass(a) :: cp_from_i => psb_lz_cp_from_i + procedure, pass(a) :: cp_to_i => psb_lz_cp_to_i generic, public :: mv_from => mv_from_ib, mv_from_i generic, public :: mv_to => mv_to_ib, mv_to_i generic, public :: cp_from => cp_from_ib, cp_from_i generic, public :: cp_to => cp_to_ib, cp_to_i - ! Computational routines + ! Computational routines procedure, pass(a) :: get_diag => psb_lz_get_diag procedure, pass(a) :: maxval => psb_lz_maxval procedure, pass(a) :: spnmi => psb_lz_csnmi @@ -419,6 +424,11 @@ module psb_z_mat_mod procedure, pass(a) :: scals => psb_lz_scals procedure, pass(a) :: scalv => psb_lz_scal generic, public :: scal => scals, scalv + procedure, pass(a) :: scalpid => psb_lz_scalplusidentity + procedure, pass(a) :: spaxpby => psb_lz_spaxpby + procedure, pass(a) :: cmpval => psb_lz_cmpval + procedure, pass(a) :: cmpmat => psb_lz_cmpmat + generic, public :: spcmp => cmpval, cmpmat end type psb_lzspmat_type @@ -449,7 +459,7 @@ module psb_z_mat_mod ! ! ! - ! Setters + ! Setters ! ! ! @@ -459,142 +469,142 @@ module psb_z_mat_mod ! == =================================== - interface - subroutine psb_z_set_nrows(m,a) + interface + subroutine psb_z_set_nrows(m,a) import :: psb_ipk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_z_set_nrows end interface - - interface - subroutine psb_z_set_ncols(n,a) + + interface + subroutine psb_z_set_ncols(n,a) import :: psb_ipk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_z_set_ncols end interface - - interface - subroutine psb_z_set_dupl(n,a) + + interface + subroutine psb_z_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_z_set_dupl end interface - - interface - subroutine psb_z_set_null(a) + + interface + subroutine psb_z_set_null(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_null end interface - - interface - subroutine psb_z_set_bld(a) + + interface + subroutine psb_z_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_bld end interface - - interface - subroutine psb_z_set_upd(a) + + interface + subroutine psb_z_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_upd end interface - - interface - subroutine psb_z_set_asb(a) + + interface + subroutine psb_z_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_set_asb end interface - - interface - subroutine psb_z_set_sorted(a,val) + + interface + subroutine psb_z_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_sorted end interface - - interface - subroutine psb_z_set_triangle(a,val) + + interface + subroutine psb_z_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_triangle end interface - - interface - subroutine psb_z_set_symmetric(a,val) + + interface + subroutine psb_z_set_symmetric(a,val) import :: psb_ipk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_symmetric end interface - - interface - subroutine psb_z_set_unit(a,val) + + interface + subroutine psb_z_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_unit end interface - - interface - subroutine psb_z_set_lower(a,val) + + interface + subroutine psb_z_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_lower end interface - - interface - subroutine psb_z_set_upper(a,val) + + interface + subroutine psb_z_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_z_set_upper end interface - - interface + + interface subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_zspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_z_sparse_print end interface - interface + interface subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_zspmat_type character(len=*), intent(in) :: fname - class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_z_n_sparse_print end interface - - interface + + interface subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_zspmat_type - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev end subroutine psb_z_get_neigh end interface - - interface - subroutine psb_z_csall(nr,nc,a,info,nz) + + interface + subroutine psb_z_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc @@ -602,31 +612,31 @@ module psb_z_mat_mod integer(psb_ipk_), intent(in), optional :: nz end subroutine psb_z_csall end interface - - interface - subroutine psb_z_reallocate_nz(nz,a) + + interface + subroutine psb_z_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type integer(psb_ipk_), intent(in) :: nz class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_reallocate_nz end interface - - interface - subroutine psb_z_free(a) + + interface + subroutine psb_z_free(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_free end interface - - interface - subroutine psb_z_trim(a) + + interface + subroutine psb_z_trim(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_trim end interface - - interface - subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -635,9 +645,9 @@ module psb_z_mat_mod end subroutine psb_z_csput_a end interface - - interface - subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_vect_mod, only : psb_z_vect_type use psb_i_vect_mod, only : psb_i_vect_type import :: psb_ipk_, psb_lpk_, psb_zspmat_type @@ -648,8 +658,8 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csput_v end interface - - interface + + interface subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -664,8 +674,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_csgetptn end interface - - interface + + interface subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -681,8 +691,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_csgetrow end interface - - interface + + interface subroutine psb_z_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -696,8 +706,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_csgetblk end interface - - interface + + interface subroutine psb_z_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -709,8 +719,8 @@ module psb_z_mat_mod class(psb_zspmat_type), optional, intent(inout) :: u end subroutine psb_z_tril end interface - - interface + + interface subroutine psb_z_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -724,7 +734,7 @@ module psb_z_mat_mod end interface - interface + interface subroutine psb_z_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -736,7 +746,7 @@ module psb_z_mat_mod end subroutine psb_z_csclip end interface - interface + interface subroutine psb_z_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -746,8 +756,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_csclip_ip end interface - - interface + + interface subroutine psb_z_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_coo_sparse_mat @@ -758,60 +768,60 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_z_b_csclip end interface - - interface + + interface subroutine psb_z_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_z_mold end interface - - interface - subroutine psb_z_asb(a,mold) + + interface + subroutine psb_z_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_z_asb end interface - - interface + + interface subroutine psb_z_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_transp_1mat end interface - - interface + + interface subroutine psb_z_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b end subroutine psb_z_transp_2mat end interface - - interface + + interface subroutine psb_z_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a end subroutine psb_z_transc_1mat end interface - - interface + + interface subroutine psb_z_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b end subroutine psb_z_transc_2mat end interface - - interface + + interface subroutine psb_z_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_reinit - + end interface @@ -826,9 +836,9 @@ module psb_z_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(in) :: a @@ -839,9 +849,9 @@ module psb_z_mat_mod class(psb_z_base_sparse_mat), intent(in), optional :: mold end subroutine psb_z_cscnv end interface - - interface + + interface subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a @@ -851,9 +861,9 @@ module psb_z_mat_mod class(psb_z_base_sparse_mat), intent(in), optional :: mold end subroutine psb_z_cscnv_ip end interface - - interface + + interface subroutine psb_z_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(in) :: a @@ -862,12 +872,12 @@ module psb_z_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_z_cscnv_base end interface - + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_z_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(in) :: a @@ -875,46 +885,46 @@ module psb_z_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_z_clip_d end interface - - interface + + interface subroutine psb_z_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_z_clip_d_ip end interface - + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_z_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_z_mv_from end interface - - interface + + interface subroutine psb_z_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(out) :: a class(psb_z_base_sparse_mat), intent(in) :: b end subroutine psb_z_cp_from end interface - - interface + + interface subroutine psb_z_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_z_mv_to end interface - - interface + + interface subroutine psb_z_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_z_cp_to @@ -922,63 +932,63 @@ module psb_z_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_z_mv_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_z_mv_from_lb end interface - - interface + + interface subroutine psb_z_cp_from_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_zspmat_type), intent(out) :: a class(psb_lz_base_sparse_mat), intent(in) :: b end subroutine psb_z_cp_from_lb end interface - - interface + + interface subroutine psb_z_mv_to_lb(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_z_mv_to_lb end interface - - interface + + interface subroutine psb_z_cp_to_lb(a,b) - import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_zspmat_type), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_z_cp_to_lb end interface - interface + interface subroutine psb_z_mv_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type class(psb_zspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: b end subroutine psb_z_mv_from_l end interface - - interface + + interface subroutine psb_z_cp_from_l(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type class(psb_zspmat_type), intent(out) :: a class(psb_lzspmat_type), intent(in) :: b end subroutine psb_z_cp_from_l end interface - - interface + + interface subroutine psb_z_mv_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type class(psb_zspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: b end subroutine psb_z_mv_to_l end interface - - interface + + interface subroutine psb_z_cp_to_l(a,b) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type class(psb_zspmat_type), intent(in) :: a @@ -988,8 +998,8 @@ module psb_z_mat_mod ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_zspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a @@ -997,8 +1007,8 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_zspmat_type_move end interface - - interface + + interface subroutine psb_zspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_zspmat_type class(psb_zspmat_type), intent(inout) :: a @@ -1024,7 +1034,7 @@ module psb_z_mat_mod ! == =================================== interface psb_csmm - subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) + subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1032,7 +1042,7 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_z_csmm - subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) + subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -1040,7 +1050,7 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans end subroutine psb_z_csmv - subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) + subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_z_vect_mod, only : psb_z_vect_type import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1051,9 +1061,9 @@ module psb_z_mat_mod character, optional, intent(in) :: trans end subroutine psb_z_csmv_vect end interface - + interface psb_cssm - subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) @@ -1062,7 +1072,7 @@ module psb_z_mat_mod character, optional, intent(in) :: trans, scale complex(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_z_cssm - subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -1071,7 +1081,7 @@ module psb_z_mat_mod character, optional, intent(in) :: trans, scale complex(psb_dpk_), intent(in), optional :: d(:) end subroutine psb_z_cssv - subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_z_vect_mod, only : psb_z_vect_type import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1083,24 +1093,24 @@ module psb_z_mat_mod type(psb_z_vect_type), optional, intent(inout) :: d end subroutine psb_z_cssv_vect end interface - - interface + + interface function psb_z_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_z_maxval end interface - - interface + + interface function psb_z_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csnmi end interface - - interface + + interface function psb_z_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1108,7 +1118,7 @@ module psb_z_mat_mod end function psb_z_csnm1 end interface - interface + interface function psb_z_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1117,7 +1127,7 @@ module psb_z_mat_mod end function psb_z_rowsum end interface - interface + interface function psb_z_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1125,8 +1135,8 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_z_arwsum end interface - - interface + + interface function psb_z_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1135,7 +1145,7 @@ module psb_z_mat_mod end function psb_z_colsum end interface - interface + interface function psb_z_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1144,7 +1154,7 @@ module psb_z_mat_mod end function psb_z_aclsum end interface - interface + interface function psb_z_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ class(psb_zspmat_type), intent(in) :: a @@ -1152,7 +1162,7 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_z_get_diag end interface - + interface psb_scal subroutine psb_z_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ @@ -1169,12 +1179,53 @@ module psb_z_mat_mod end subroutine psb_z_scals end interface + interface psb_scalplusidentity + subroutine psb_z_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_z_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_spaxpby + end interface + + interface + function psb_z_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_z_cmpval + end interface + + interface + function psb_z_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_z_cmpmat + end interface ! == =================================== ! ! ! - ! Setters + ! Setters ! ! ! @@ -1184,156 +1235,156 @@ module psb_z_mat_mod ! == =================================== - interface - subroutine psb_lz_set_lnrows(m,a) + interface + subroutine psb_lz_set_lnrows(m,a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m end subroutine psb_lz_set_lnrows #if defined(IPK4) && defined(LPK8) - subroutine psb_lz_set_inrows(m,a) + subroutine psb_lz_set_inrows(m,a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m end subroutine psb_lz_set_inrows #endif end interface - - interface - subroutine psb_lz_set_lncols(n,a) + + interface + subroutine psb_lz_set_lncols(n,a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n end subroutine psb_lz_set_lncols -#if defined(IPK4) && defined(LPK8) - subroutine psb_lz_set_incols(n,a) +#if defined(IPK4) && defined(LPK8) + subroutine psb_lz_set_incols(n,a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_lz_set_incols #endif end interface - - interface - subroutine psb_lz_set_dupl(n,a) + + interface + subroutine psb_lz_set_dupl(n,a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n end subroutine psb_lz_set_dupl end interface - - interface - subroutine psb_lz_set_null(a) + + interface + subroutine psb_lz_set_null(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_set_null end interface - - interface - subroutine psb_lz_set_bld(a) + + interface + subroutine psb_lz_set_bld(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_set_bld end interface - - interface - subroutine psb_lz_set_upd(a) + + interface + subroutine psb_lz_set_upd(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_set_upd end interface - - interface - subroutine psb_lz_set_asb(a) + + interface + subroutine psb_lz_set_asb(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_set_asb end interface - - interface - subroutine psb_lz_set_sorted(a,val) + + interface + subroutine psb_lz_set_sorted(a,val) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lz_set_sorted end interface - - interface - subroutine psb_lz_set_triangle(a,val) + + interface + subroutine psb_lz_set_triangle(a,val) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lz_set_triangle end interface - - interface - subroutine psb_lz_set_symmetric(a,val) + + interface + subroutine psb_lz_set_symmetric(a,val) import :: psb_ipk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lz_set_symmetric end interface - - interface - subroutine psb_lz_set_unit(a,val) + + interface + subroutine psb_lz_set_unit(a,val) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lz_set_unit end interface - - interface - subroutine psb_lz_set_lower(a,val) + + interface + subroutine psb_lz_set_lower(a,val) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lz_set_lower end interface - - interface - subroutine psb_lz_set_upper(a,val) + + interface + subroutine psb_lz_set_upper(a,val) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val end subroutine psb_lz_set_upper end interface - - interface + + interface subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type integer(psb_ipk_), intent(in) :: iout - class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lz_sparse_print end interface - interface + interface subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type character(len=*), intent(in) :: fname - class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) end subroutine psb_lz_n_sparse_print end interface - - interface + + interface subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type - class(psb_lzspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev end subroutine psb_lz_get_neigh end interface - - interface - subroutine psb_lz_csall(nr,nc,a,info,nz) + + interface + subroutine psb_lz_csall(nr,nc,a,info,nz) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc @@ -1341,31 +1392,31 @@ module psb_z_mat_mod integer(psb_lpk_), intent(in), optional :: nz end subroutine psb_lz_csall end interface - - interface - subroutine psb_lz_reallocate_nz(nz,a) + + interface + subroutine psb_lz_reallocate_nz(nz,a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type integer(psb_lpk_), intent(in) :: nz class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_reallocate_nz end interface - - interface - subroutine psb_lz_free(a) + + interface + subroutine psb_lz_free(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_free end interface - - interface - subroutine psb_lz_trim(a) + + interface + subroutine psb_lz_trim(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_trim end interface - - interface - subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -1374,9 +1425,9 @@ module psb_z_mat_mod end subroutine psb_lz_csput_a end interface - - interface - subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) + + interface + subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_vect_mod, only : psb_z_vect_type use psb_l_vect_mod, only : psb_l_vect_type import :: psb_ipk_, psb_lpk_, psb_lzspmat_type @@ -1387,8 +1438,8 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_csput_v end interface - - interface + + interface subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1403,8 +1454,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csgetptn end interface - - interface + + interface subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1420,8 +1471,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csgetrow end interface - - interface + + interface subroutine psb_lz_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1435,8 +1486,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csgetblk end interface - - interface + + interface subroutine psb_lz_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1448,8 +1499,8 @@ module psb_z_mat_mod class(psb_lzspmat_type), optional, intent(inout) :: u end subroutine psb_lz_tril end interface - - interface + + interface subroutine psb_lz_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1463,7 +1514,7 @@ module psb_z_mat_mod end interface - interface + interface subroutine psb_lz_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1475,7 +1526,7 @@ module psb_z_mat_mod end subroutine psb_lz_csclip end interface - interface + interface subroutine psb_lz_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1485,8 +1536,8 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_csclip_ip end interface - - interface + + interface subroutine psb_lz_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_coo_sparse_mat @@ -1497,60 +1548,60 @@ module psb_z_mat_mod logical, intent(in), optional :: rscale,cscale end subroutine psb_lz_b_csclip end interface - - interface + + interface subroutine psb_lz_mold(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), allocatable, intent(out) :: b end subroutine psb_lz_mold end interface - - interface - subroutine psb_lz_asb(a,mold) + + interface + subroutine psb_lz_asb(a,mold) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), optional, intent(in) :: mold end subroutine psb_lz_asb end interface - - interface + + interface subroutine psb_lz_transp_1mat(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_transp_1mat end interface - - interface + + interface subroutine psb_lz_transp_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: b end subroutine psb_lz_transp_2mat end interface - - interface + + interface subroutine psb_lz_transc_1mat(a) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a end subroutine psb_lz_transc_1mat end interface - - interface + + interface subroutine psb_lz_transc_2mat(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: b end subroutine psb_lz_transc_2mat end interface - - interface + + interface subroutine psb_lz_reinit(a,clear) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type - class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_lz_reinit - + end interface @@ -1565,9 +1616,9 @@ module psb_z_mat_mod ! 3 versions: copying to target ! copying to a base_sparse_mat object. ! in place - ! ! - interface + ! + interface subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(in) :: a @@ -1578,9 +1629,9 @@ module psb_z_mat_mod class(psb_lz_base_sparse_mat), intent(in), optional :: mold end subroutine psb_lz_cscnv end interface - - interface + + interface subroutine psb_lz_cscnv_ip(a,iinfo,type,mold,dupl) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a @@ -1590,9 +1641,9 @@ module psb_z_mat_mod class(psb_lz_base_sparse_mat), intent(in), optional :: mold end subroutine psb_lz_cscnv_ip end interface - - interface + + interface subroutine psb_lz_cscnv_base(a,b,info,dupl) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(in) :: a @@ -1601,13 +1652,13 @@ module psb_z_mat_mod integer(psb_ipk_),optional, intent(in) :: dupl end subroutine psb_lz_cscnv_base end interface - - + + ! ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. + ! out; passes through a COO buffer. ! - interface + interface subroutine psb_lz_clip_d(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(in) :: a @@ -1615,47 +1666,47 @@ module psb_z_mat_mod integer(psb_ipk_),intent(out) :: info end subroutine psb_lz_clip_d end interface - - interface + + interface subroutine psb_lz_clip_d_ip(a,info) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_),intent(out) :: info end subroutine psb_lz_clip_d_ip end interface - - + + ! ! These four interfaces cut through the ! encapsulation between spmat_type and base_sparse_mat. ! - interface + interface subroutine psb_lz_mv_from(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_mv_from end interface - - interface + + interface subroutine psb_lz_cp_from(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(out) :: a class(psb_lz_base_sparse_mat), intent(in) :: b end subroutine psb_lz_cp_from end interface - - interface + + interface subroutine psb_lz_mv_to(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_mv_to end interface - - interface + + interface subroutine psb_lz_cp_to(a,b) - import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat class(psb_lzspmat_type), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_cp_to @@ -1663,63 +1714,63 @@ module psb_z_mat_mod ! ! Mixed type conversions ! - interface + interface subroutine psb_lz_mv_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_mv_from_ib end interface - - interface + + interface subroutine psb_lz_cp_from_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_lzspmat_type), intent(out) :: a class(psb_z_base_sparse_mat), intent(in) :: b end subroutine psb_lz_cp_from_ib end interface - - interface + + interface subroutine psb_lz_mv_to_ib(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_lzspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_mv_to_ib end interface - - interface + + interface subroutine psb_lz_cp_to_ib(a,b) - import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat class(psb_lzspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b end subroutine psb_lz_cp_to_ib end interface - interface + interface subroutine psb_lz_mv_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type class(psb_lzspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b end subroutine psb_lz_mv_from_i end interface - - interface + + interface subroutine psb_lz_cp_from_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type class(psb_lzspmat_type), intent(out) :: a class(psb_zspmat_type), intent(in) :: b end subroutine psb_lz_cp_from_i end interface - - interface + + interface subroutine psb_lz_mv_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type class(psb_lzspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b end subroutine psb_lz_mv_to_i end interface - - interface + + interface subroutine psb_lz_cp_to_i(a,b) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type class(psb_lzspmat_type), intent(in) :: a @@ -1727,11 +1778,11 @@ module psb_z_mat_mod end subroutine psb_lz_cp_to_i end interface - + ! ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc + ! + interface psb_move_alloc subroutine psb_lzspmat_type_move(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a @@ -1739,8 +1790,8 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lzspmat_type_move end interface - - interface + + interface subroutine psb_lzspmat_clone(a,b,info) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type class(psb_lzspmat_type), intent(inout) :: a @@ -1751,7 +1802,7 @@ module psb_z_mat_mod - interface + interface function psb_lz_get_diag(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a @@ -1759,7 +1810,7 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_lz_get_diag end interface - + interface psb_scal subroutine psb_lz_scal(d,a,info,side) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ @@ -1776,23 +1827,43 @@ module psb_z_mat_mod end subroutine psb_lz_scals end interface - interface + interface psb_scalplusidentity + subroutine psb_lz_scalplusidentity(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_scalplusidentity + end interface + + interface psb_spaxpby + subroutine psb_lz_spaxpby(alpha,a,beta,b,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_spaxpby + end interface + + interface function psb_lz_maxval(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_maxval end interface - - interface + + interface function psb_lz_csnmi(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_) :: res end function psb_lz_csnmi end interface - - interface + + interface function psb_lz_csnm1(a) result(res) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a @@ -1800,7 +1871,7 @@ module psb_z_mat_mod end function psb_lz_csnm1 end interface - interface + interface function psb_lz_rowsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a @@ -1809,7 +1880,7 @@ module psb_z_mat_mod end function psb_lz_rowsum end interface - interface + interface function psb_lz_arwsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a @@ -1817,8 +1888,8 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_lz_arwsum end interface - - interface + + interface function psb_lz_colsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a @@ -1827,7 +1898,7 @@ module psb_z_mat_mod end function psb_lz_colsum end interface - interface + interface function psb_lz_aclsum(a,info) result(d) import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ class(psb_lzspmat_type), intent(in) :: a @@ -1835,40 +1906,59 @@ module psb_z_mat_mod integer(psb_ipk_), intent(out) :: info end function psb_lz_aclsum end interface - -contains - subroutine psb_z_set_mat_default(a) - implicit none + interface psb_cmpmat + function psb_lz_cmpval(a,val,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lz_cmpval + function psb_lz_cmpmat(a,b,tol,info) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + end function psb_lz_cmpmat + end interface + +contains + + subroutine psb_z_set_mat_default(a) + implicit none class(psb_z_base_sparse_mat), intent(in) :: a - - if (allocated(psb_z_base_mat_default)) then + + if (allocated(psb_z_base_mat_default)) then deallocate(psb_z_base_mat_default) end if allocate(psb_z_base_mat_default, mold=a) end subroutine psb_z_set_mat_default - + function psb_z_get_mat_default(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), pointer :: res - + res => psb_z_get_base_mat_default() - + end function psb_z_get_mat_default - + function psb_z_get_base_mat_default() result(res) - implicit none + implicit none class(psb_z_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_z_base_mat_default)) then + + if (.not.allocated(psb_z_base_mat_default)) then allocate(psb_z_csr_sparse_mat :: psb_z_base_mat_default) end if res => psb_z_base_mat_default - + end function psb_z_get_base_mat_default subroutine psb_z_clear_mat_default() @@ -1886,7 +1976,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -1894,26 +1984,26 @@ contains ! ! == =================================== - + function psb_z_sizeof(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_z_sizeof function psb_z_get_fmt(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -1923,11 +2013,11 @@ contains function psb_z_get_dupl(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -1935,11 +2025,11 @@ contains end function psb_z_get_dupl function psb_z_get_nrows(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -1948,11 +2038,11 @@ contains end function psb_z_get_nrows function psb_z_get_ncols(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -1961,11 +2051,11 @@ contains end function psb_z_get_ncols function psb_z_is_triangle(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -1974,11 +2064,11 @@ contains end function psb_z_is_triangle function psb_z_is_symmetric(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -1987,11 +2077,11 @@ contains end function psb_z_is_symmetric function psb_z_is_unit(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2000,11 +2090,11 @@ contains end function psb_z_is_unit function psb_z_is_upper(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2013,11 +2103,11 @@ contains end function psb_z_is_upper function psb_z_is_lower(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2026,12 +2116,12 @@ contains end function psb_z_is_lower function psb_z_is_null(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2039,11 +2129,11 @@ contains end function psb_z_is_null function psb_z_is_bld(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2052,11 +2142,11 @@ contains end function psb_z_is_bld function psb_z_is_upd(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2065,11 +2155,11 @@ contains end function psb_z_is_upd function psb_z_is_asb(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2078,11 +2168,11 @@ contains end function psb_z_is_asb function psb_z_is_sorted(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2091,11 +2181,11 @@ contains end function psb_z_is_sorted function psb_z_is_by_rows(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2104,11 +2194,11 @@ contains end function psb_z_is_by_rows function psb_z_is_by_cols(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2119,61 +2209,61 @@ contains ! subroutine z_mat_sync(a) - implicit none + implicit none class(psb_zspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine z_mat_sync ! subroutine z_mat_set_host(a) - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine z_mat_set_host ! subroutine z_mat_set_dev(a) - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine z_mat_set_dev ! subroutine z_mat_set_sync(a) - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine z_mat_set_sync ! function z_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function z_mat_is_dev - + ! function z_mat_is_host(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2183,11 +2273,11 @@ contains ! function z_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2198,11 +2288,11 @@ contains function psb_z_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2210,25 +2300,25 @@ contains end function psb_z_is_repeatable_updates - subroutine psb_z_set_repeatable_updates(a,val) - implicit none + subroutine psb_z_set_repeatable_updates(a,val) + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_z_set_repeatable_updates function psb_z_get_nzeros(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2236,13 +2326,13 @@ contains function psb_z_get_size(a) result(res) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2250,23 +2340,23 @@ contains function psb_z_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_ipk_), intent(in) :: idx class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_z_get_nz_row subroutine psb_z_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_zspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_z_clean_zeros @@ -2274,7 +2364,7 @@ contains #if defined(IPK4) && defined(LPK8) subroutine psb_z_lcsgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2303,17 +2393,17 @@ contains end if call a%csget(imin,imax,nz,lia,lja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_z_lcsgetptn - + subroutine psb_z_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -2342,12 +2432,12 @@ contains call a%csget(imin,imax,nz,lia,lja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - + call psb_ensure_size(size(lia),ia,info) if (info == psb_success_) ia(:) = lia(:) call psb_ensure_size(size(lja),ja,info) if (info == psb_success_) ja(:) = lja(:) - + end subroutine psb_z_lcsgetrow #endif @@ -2355,38 +2445,38 @@ contains ! lz methods ! - - subroutine psb_lz_set_mat_default(a) - implicit none + + subroutine psb_lz_set_mat_default(a) + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a - - if (allocated(psb_lz_base_mat_default)) then + + if (allocated(psb_lz_base_mat_default)) then deallocate(psb_lz_base_mat_default) end if allocate(psb_lz_base_mat_default, mold=a) end subroutine psb_lz_set_mat_default - + function psb_lz_get_mat_default(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lz_base_sparse_mat), pointer :: res - + res => psb_lz_get_base_mat_default() - + end function psb_lz_get_mat_default - + function psb_lz_get_base_mat_default() result(res) - implicit none + implicit none class(psb_lz_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_lz_base_mat_default)) then + + if (.not.allocated(psb_lz_base_mat_default)) then allocate(psb_lz_csr_sparse_mat :: psb_lz_base_mat_default) end if res => psb_lz_base_mat_default - + end function psb_lz_get_base_mat_default subroutine psb_lz_clear_mat_default() @@ -2404,7 +2494,7 @@ contains ! ! ! - ! Getters + ! Getters ! ! ! @@ -2412,26 +2502,26 @@ contains ! ! == =================================== - + function psb_lz_sizeof(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a integer(psb_epk_) :: res - + res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%sizeof() end if - + end function psb_lz_sizeof function psb_lz_get_fmt(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a character(len=5) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' @@ -2441,11 +2531,11 @@ contains function psb_lz_get_dupl(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a integer(psb_ipk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_dupl() else res = psb_invalid_ @@ -2453,11 +2543,11 @@ contains end function psb_lz_get_dupl function psb_lz_get_nrows(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nrows() else res = 0 @@ -2466,11 +2556,11 @@ contains end function psb_lz_get_nrows function psb_lz_get_ncols(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_) :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_ncols() else res = 0 @@ -2479,11 +2569,11 @@ contains end function psb_lz_get_ncols function psb_lz_is_triangle(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_triangle() else res = .false. @@ -2493,11 +2583,11 @@ contains function psb_lz_is_symmetric(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_symmetric() else res = .false. @@ -2506,11 +2596,11 @@ contains end function psb_lz_is_symmetric function psb_lz_is_unit(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_unit() else res = .false. @@ -2519,11 +2609,11 @@ contains end function psb_lz_is_unit function psb_lz_is_upper(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upper() else res = .false. @@ -2532,11 +2622,11 @@ contains end function psb_lz_is_upper function psb_lz_is_lower(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = .not. a%a%is_upper() else res = .false. @@ -2545,12 +2635,12 @@ contains end function psb_lz_is_lower function psb_lz_is_null(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then - res = a%a%is_null() + if (allocated(a%a)) then + res = a%a%is_null() else res = .true. end if @@ -2558,11 +2648,11 @@ contains end function psb_lz_is_null function psb_lz_is_bld(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_bld() else res = .false. @@ -2571,11 +2661,11 @@ contains end function psb_lz_is_bld function psb_lz_is_upd(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_upd() else res = .false. @@ -2584,11 +2674,11 @@ contains end function psb_lz_is_upd function psb_lz_is_asb(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_asb() else res = .false. @@ -2597,11 +2687,11 @@ contains end function psb_lz_is_asb function psb_lz_is_sorted(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_sorted() else res = .false. @@ -2610,11 +2700,11 @@ contains end function psb_lz_is_sorted function psb_lz_is_by_rows(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_rows() else res = .false. @@ -2623,11 +2713,11 @@ contains end function psb_lz_is_by_rows function psb_lz_is_by_cols(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_by_cols() else res = .false. @@ -2638,61 +2728,61 @@ contains ! subroutine lz_mat_sync(a) - implicit none + implicit none class(psb_lzspmat_type), target, intent(in) :: a - + if (allocated(a%a)) call a%a%sync() end subroutine lz_mat_sync ! subroutine lz_mat_set_host(a) - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_host() - + end subroutine lz_mat_set_host ! subroutine lz_mat_set_dev(a) - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_dev() - + end subroutine lz_mat_set_dev ! subroutine lz_mat_set_sync(a) - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a if (allocated(a%a)) call a%a%set_sync() - + end subroutine lz_mat_set_sync ! function lz_mat_is_dev(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_dev() else res = .false. end if end function lz_mat_is_dev - + ! function lz_mat_is_host(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_host() else @@ -2702,11 +2792,11 @@ contains ! function lz_mat_is_sync(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_sync() else @@ -2717,11 +2807,11 @@ contains function psb_lz_is_repeatable_updates(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a logical :: res - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%is_repeatable_updates() else res = .false. @@ -2729,25 +2819,25 @@ contains end function psb_lz_is_repeatable_updates - subroutine psb_lz_set_repeatable_updates(a,val) - implicit none + subroutine psb_lz_set_repeatable_updates(a,val) + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val - - if (allocated(a%a)) then + + if (allocated(a%a)) then call a%a%set_repeatable_updates(val) end if - + end subroutine psb_lz_set_repeatable_updates function psb_lz_get_nzeros(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_nzeros() end if @@ -2755,13 +2845,13 @@ contains function psb_lz_get_size(a) result(res) - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - if (allocated(a%a)) then + if (allocated(a%a)) then res = a%a%get_size() end if @@ -2769,23 +2859,23 @@ contains function psb_lz_get_nz_row(idx,a) result(res) - implicit none + implicit none integer(psb_lpk_), intent(in) :: idx class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_) :: res res = 0 - + if (allocated(a%a)) res = a%a%get_nz_row(idx) end function psb_lz_get_nz_row subroutine psb_lz_clean_zeros(a,info) - implicit none + implicit none integer(psb_ipk_), intent(out) :: info class(psb_lzspmat_type), intent(inout) :: a - info = 0 + info = 0 if (allocated(a%a)) call a%a%clean_zeros(info) end subroutine psb_lz_clean_zeros @@ -2793,7 +2883,7 @@ contains #if defined(IPK4) && defined(LPK8) !!$ subroutine psb_lz_icsgetptn(imin,imax,a,nz,ia,ja,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_lzspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2829,12 +2919,12 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_lz_icsgetptn -!!$ +!!$ !!$ subroutine psb_lz_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& !!$ & jmin,jmax,iren,append,nzin,rscale,cscale) -!!$ implicit none +!!$ implicit none !!$ class(psb_lzspmat_type), intent(in) :: a !!$ integer(psb_ipk_), intent(in) :: imin,imax !!$ integer(psb_ipk_), intent(out) :: nz @@ -2870,7 +2960,7 @@ contains !!$ if (info == psb_success_) ia(:) = lia(:) !!$ call psb_ensure_size(size(lja),ja,info) !!$ if (info == psb_success_) ja(:) = lja(:) -!!$ +!!$ !!$ end subroutine psb_lz_icsgetrow #endif diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index a0336d862..8ab68a532 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,15 +27,15 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! package: psb_z_vect_mod ! ! This module contains the definition of the psb_z_vect type which ! is the outer container for dense vectors. ! Therefore all methods simply invoke the corresponding methods of the -! inner component. +! inner component. ! module psb_z_vect_mod @@ -43,7 +43,7 @@ module psb_z_vect_mod use psb_i_vect_mod type psb_z_vect_type - class(psb_z_base_vect_type), allocatable :: v + class(psb_z_base_vect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => z_vect_get_nrows procedure, pass(x) :: sizeof => z_vect_sizeof @@ -85,7 +85,9 @@ module psb_z_vect_mod generic, public :: dot => dot_v, dot_a procedure, pass(y) :: axpby_v => z_vect_axpby_v procedure, pass(y) :: axpby_a => z_vect_axpby_a - generic, public :: axpby => axpby_v, axpby_a + procedure, pass(z) :: axpby_v2 => z_vect_axpby_v2 + procedure, pass(z) :: axpby_a2 => z_vect_axpby_a2 + generic, public :: axpby => axpby_v, axpby_a, axpby_v2, axpby_a2 procedure, pass(y) :: mlt_v => z_vect_mlt_v procedure, pass(y) :: mlt_a => z_vect_mlt_a procedure, pass(z) :: mlt_a_2 => z_vect_mlt_a_2 @@ -94,13 +96,37 @@ module psb_z_vect_mod procedure, pass(z) :: mlt_av => z_vect_mlt_av generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,& & mlt_v_2, mlt_av, mlt_va + procedure, pass(x) :: div_v => z_vect_div_v + procedure, pass(z) :: div_v2 => z_vect_div_v2 + procedure, pass(x) :: div_v_check => z_vect_div_v_check + procedure, pass(x) :: div_v2_check => z_vect_div_v2_check + procedure, pass(z) :: div_a2 => z_vect_div_a2 + procedure, pass(z) :: div_a2_check => z_vect_div_a2_check + generic, public :: div => div_v, div_v2, div_v_check, & + div_v2_check, div_a2, div_a2_check + procedure, pass(y) :: inv_v => z_vect_inv_v + procedure, pass(y) :: inv_v_check => z_vect_inv_v_check + procedure, pass(y) :: inv_a2 => z_vect_inv_a2 + procedure, pass(y) :: inv_a2_check => z_vect_inv_a2_check + generic, public :: inv => inv_v, inv_v_check, inv_a2, inv_a2_check procedure, pass(x) :: scal => z_vect_scal procedure, pass(x) :: absval1 => z_vect_absval1 procedure, pass(x) :: absval2 => z_vect_absval2 generic, public :: absval => absval1, absval2 - procedure, pass(x) :: nrm2 => z_vect_nrm2 + procedure, pass(x) :: nrm2std => z_vect_nrm2 + procedure, pass(x) :: nrm2weight => z_vect_nrm2_weight + procedure, pass(x) :: nrm2weightmask => z_vect_nrm2_weight_mask + generic, public :: nrm2 => nrm2std, nrm2weight, nrm2weightmask procedure, pass(x) :: amax => z_vect_amax - procedure, pass(x) :: asum => z_vect_asum + procedure, pass(x) :: asum => z_vect_asum + procedure, pass(z) :: acmp_a2 => z_vect_acmp_a2 + procedure, pass(z) :: acmp_v2 => z_vect_acmp_v2 + generic, public :: acmp => acmp_a2, acmp_v2 + procedure, pass(z) :: addconst_a2 => z_vect_addconst_a2 + procedure, pass(z) :: addconst_v2 => z_vect_addconst_v2 + generic, public :: addconst => addconst_a2, addconst_v2 + + end type psb_z_vect_type public :: psb_z_vect @@ -122,8 +148,7 @@ module psb_z_vect_mod private :: z_vect_dot_v, z_vect_dot_a, z_vect_axpby_v, z_vect_axpby_a, & & z_vect_mlt_v, z_vect_mlt_a, z_vect_mlt_a_2, z_vect_mlt_v_2, & & z_vect_mlt_va, z_vect_mlt_av, z_vect_scal, z_vect_absval1, & - & z_vect_absval2, z_vect_nrm2, z_vect_amax, z_vect_asum - + & z_vect_absval2, z_vect_nrm2, z_vect_amax, z_vect_asum class(psb_z_base_vect_type), allocatable, target,& @@ -141,11 +166,11 @@ module psb_z_vect_mod contains - subroutine psb_z_set_vect_default(v) - implicit none + subroutine psb_z_set_vect_default(v) + implicit none class(psb_z_base_vect_type), intent(in) :: v - if (allocated(psb_z_base_vect_default)) then + if (allocated(psb_z_base_vect_default)) then deallocate(psb_z_base_vect_default) end if allocate(psb_z_base_vect_default, mold=v) @@ -153,7 +178,7 @@ contains end subroutine psb_z_set_vect_default function psb_z_get_vect_default(v) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: v class(psb_z_base_vect_type), pointer :: res @@ -171,10 +196,10 @@ contains end subroutine psb_z_clear_vect_default function psb_z_get_base_vect_default() result(res) - implicit none + implicit none class(psb_z_base_vect_type), pointer :: res - if (.not.allocated(psb_z_base_vect_default)) then + if (.not.allocated(psb_z_base_vect_default)) then allocate(psb_z_base_vect_type :: psb_z_base_vect_default) end if @@ -183,14 +208,14 @@ contains end function psb_z_get_base_vect_default subroutine z_vect_clone(x,y,info) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine z_vect_clone @@ -205,7 +230,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) @@ -227,7 +252,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) @@ -247,7 +272,7 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) @@ -310,7 +335,7 @@ contains end function size_const function z_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -318,7 +343,7 @@ contains end function z_vect_get_nrows function z_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -326,7 +351,7 @@ contains end function z_vect_sizeof function z_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -335,7 +360,7 @@ contains subroutine z_vect_all(n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold @@ -344,12 +369,12 @@ contains if (allocated(x%v)) & & call x%free(info) - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_z_base_vect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(n,info) else info = psb_err_alloc_dealloc_ @@ -359,12 +384,12 @@ contains subroutine z_vect_reall(n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(n,info) if (info == 0) & @@ -374,7 +399,7 @@ contains subroutine z_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -384,7 +409,7 @@ contains subroutine z_vect_asb(n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -430,12 +455,12 @@ contains subroutine z_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -444,7 +469,7 @@ contains subroutine z_vect_ins_a(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -454,7 +479,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -465,7 +490,7 @@ contains subroutine z_vect_ins_v(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl class(psb_i_vect_type), intent(inout) :: irl @@ -475,7 +500,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then info = psb_err_invalid_vect_state_ return end if @@ -493,12 +518,12 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info,mold=psb_z_get_base_vect_default()) end if - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -509,7 +534,7 @@ contains subroutine z_vect_sync(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -518,7 +543,7 @@ contains end subroutine z_vect_sync subroutine z_vect_set_sync(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -527,7 +552,7 @@ contains end subroutine z_vect_set_sync subroutine z_vect_set_host(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -536,7 +561,7 @@ contains end subroutine z_vect_set_host subroutine z_vect_set_dev(x) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x if (allocated(x%v)) & @@ -545,7 +570,7 @@ contains end subroutine z_vect_set_dev function z_vect_is_sync(x) result(res) - implicit none + implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x @@ -556,7 +581,7 @@ contains end function z_vect_is_sync function z_vect_is_host(x) result(res) - implicit none + implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x @@ -567,11 +592,11 @@ contains end function z_vect_is_host function z_vect_is_dev(x) result(res) - implicit none + implicit none logical :: res class(psb_z_vect_type), intent(inout) :: x - res = .false. + res = .false. if (allocated(x%v)) & & res = x%v%is_dev() @@ -579,7 +604,7 @@ contains function z_vect_dot_v(n,x,y) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x, y integer(psb_ipk_), intent(in) :: n complex(psb_dpk_) :: res @@ -591,7 +616,7 @@ contains end function z_vect_dot_v function z_vect_dot_a(n,x,y) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent(in) :: y(:) integer(psb_ipk_), intent(in) :: n @@ -605,14 +630,14 @@ contains subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - if (allocated(x%v).and.allocated(y%v)) then + if (allocated(x%v).and.allocated(y%v)) then call y%v%axpby(m,alpha,x%v,beta,info) else info = psb_err_invalid_vect_state_ @@ -620,9 +645,27 @@ contains end subroutine z_vect_axpby_v + subroutine z_vect_axpby_v2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v).and.allocated(y%v)) then + call z%v%axpby(m,alpha,x%v,beta,y%v,info) + else + info = psb_err_invalid_vect_state_ + end if + + end subroutine z_vect_axpby_v2 + subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) use psi_serial_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent(in) :: x(:) class(psb_z_vect_type), intent(inout) :: y @@ -634,13 +677,27 @@ contains end subroutine z_vect_axpby_a + subroutine z_vect_axpby_a2(m,alpha, x, beta, y, z, info) + use psi_serial_mod + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + + if (allocated(z%v)) & + & call z%v%axpby(m,alpha,x,beta,y,info) + + end subroutine z_vect_axpby_a2 subroutine z_vect_mlt_v(x, y, info) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -651,7 +708,7 @@ contains subroutine z_vect_mlt_a(x, y, info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: x(:) class(psb_z_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info @@ -667,7 +724,7 @@ contains subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) complex(psb_dpk_), intent(in) :: x(:) @@ -675,7 +732,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n - info = 0 + info = 0 if (allocated(z%v)) & & call z%v%mlt(alpha,x,y,beta,info) @@ -683,12 +740,12 @@ contains subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character(len=1), intent(in), optional :: conjgx, conjgy integer(psb_ipk_) :: i, n @@ -702,12 +759,12 @@ contains subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: x(:) class(psb_z_vect_type), intent(inout) :: y class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -718,12 +775,12 @@ contains subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) use psi_serial_mod - implicit none + implicit none complex(psb_dpk_), intent(in) :: alpha,beta complex(psb_dpk_), intent(in) :: y(:) class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: z - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n info = 0 @@ -733,9 +790,186 @@ contains end subroutine z_vect_mlt_va + subroutine z_vect_div_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info) + + end subroutine z_vect_div_v + + subroutine z_vect_div_v2( x, y, z, info) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info) + + end subroutine z_vect_div_v2 + + subroutine z_vect_div_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call x%v%div(y%v,info,flag) + + end subroutine z_vect_div_v_check + + subroutine z_vect_div_v2_check(x, y, z, info, flag) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v).and.allocated(z%v)) & + & call z%v%div(x%v,y%v,info,flag) + + end subroutine z_vect_div_v2_check + + subroutine z_vect_div_a2(x, y, z, info) + use psi_serial_mod + implicit none + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info) + + end subroutine z_vect_div_a2 + + subroutine z_vect_div_a2_check(x, y, z, info,flag) + use psi_serial_mod + implicit none + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(z%v)) & + & call z%v%div(x,y,info,flag) + + end subroutine z_vect_div_a2_check + + subroutine z_vect_inv_v(x, y, info) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info) + + end subroutine z_vect_inv_v + + subroutine z_vect_inv_v_check(x, y, info, flag) + use psi_serial_mod + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(x%v).and.allocated(y%v)) & + & call y%v%inv(x%v,info,flag) + + end subroutine z_vect_inv_v_check + + subroutine z_vect_inv_a2(x, y, info) + use psi_serial_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info) + + end subroutine z_vect_inv_a2 + + subroutine z_vect_inv_a2_check(x, y, info,flag) + use psi_serial_mod + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, n + logical, intent(in) :: flag + + info = 0 + if (allocated(y%v)) & + & call y%v%inv(x,info,flag) + + end subroutine z_vect_inv_a2_check + + subroutine z_vect_acmp_a2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%acmp(x,c,info) + + end subroutine z_vect_acmp_a2 + + subroutine z_vect_acmp_v2(x,c,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: c + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%acmp(x%v,c,info) + + end subroutine z_vect_acmp_v2 + subroutine z_vect_scal(alpha, x) use psi_serial_mod - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x complex(psb_dpk_), intent (in) :: alpha @@ -755,19 +989,19 @@ contains class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: y - if (allocated(x%v)) then + if (allocated(x%v)) then if (.not.allocated(y%v)) call y%bld(psb_size(x%v%v)) call x%v%absval(y%v) end if end subroutine z_vect_absval2 function z_vect_nrm2(n,x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%nrm2(n) else res = dzero @@ -775,13 +1009,49 @@ contains end function z_vect_nrm2 + function z_vect_nrm2_weight(n,x,w) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: w + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v)) then + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = dzero + end if + + end function z_vect_nrm2_weight + + function z_vect_nrm2_weight_mask(n,x,w,id) result(res) + implicit none + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: w + class(psb_z_vect_type), intent(inout) :: id + integer(psb_ipk_), intent(in) :: n + real(psb_dpk_) :: res + integer(psb_ipk_) :: info + + if (allocated(x%v).and.allocated(w%v).and.allocated(id%v)) then + where( abs(id%v%v) <= dzero) x%v%v = dzero + call w%v%mlt(x%v,info) + res = w%v%nrm2(n) + else + res = dzero + end if + + end function z_vect_nrm2_weight_mask + function z_vect_amax(n,x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%amax(n) else res = dzero @@ -789,13 +1059,14 @@ contains end function z_vect_amax + function z_vect_asum(n,x) result(res) - implicit none + implicit none class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n real(psb_dpk_) :: res - if (allocated(x%v)) then + if (allocated(x%v)) then res = x%v%asum(n) else res = dzero @@ -804,6 +1075,35 @@ contains end function z_vect_asum + + subroutine z_vect_addconst_a2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: b + complex(psb_dpk_), intent(inout) :: x(:) + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(z%v)) & + & call z%addconst(x,b,info) + + end subroutine z_vect_addconst_a2 + + subroutine z_vect_addconst_v2(x,b,z,info) + use psi_serial_mod + implicit none + real(psb_dpk_), intent(in) :: b + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_vect_type), intent(inout) :: z + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v).and.allocated(z%v)) & + & call z%v%addconst(x%v,b,info) + + end subroutine z_vect_addconst_v2 + end module psb_z_vect_mod @@ -818,7 +1118,7 @@ module psb_z_multivect_mod !private type psb_z_multivect_type - class(psb_z_base_multivect_type), allocatable :: v + class(psb_z_base_multivect_type), allocatable :: v contains procedure, pass(x) :: get_nrows => z_vect_get_nrows procedure, pass(x) :: get_ncols => z_vect_get_ncols @@ -892,11 +1192,11 @@ module psb_z_multivect_mod contains - subroutine psb_z_set_multivect_default(v) - implicit none + subroutine psb_z_set_multivect_default(v) + implicit none class(psb_z_base_multivect_type), intent(in) :: v - if (allocated(psb_z_base_multivect_default)) then + if (allocated(psb_z_base_multivect_default)) then deallocate(psb_z_base_multivect_default) end if allocate(psb_z_base_multivect_default, mold=v) @@ -904,7 +1204,7 @@ contains end subroutine psb_z_set_multivect_default function psb_z_get_multivect_default(v) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: v class(psb_z_base_multivect_type), pointer :: res @@ -914,10 +1214,10 @@ contains function psb_z_get_base_multivect_default() result(res) - implicit none + implicit none class(psb_z_base_multivect_type), pointer :: res - if (.not.allocated(psb_z_base_multivect_default)) then + if (.not.allocated(psb_z_base_multivect_default)) then allocate(psb_z_base_multivect_type :: psb_z_base_multivect_default) end if @@ -927,14 +1227,14 @@ contains subroutine z_vect_clone(x,y,info) - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x class(psb_z_multivect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info info = psb_success_ call y%free(info) - if ((info==0).and.allocated(x%v)) then + if ((info==0).and.allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if end subroutine z_vect_clone @@ -947,7 +1247,7 @@ contains class(psb_z_base_multivect_type), pointer :: mld info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) @@ -965,7 +1265,7 @@ contains integer(psb_ipk_) :: info info = psb_success_ - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) @@ -1025,7 +1325,7 @@ contains end function size_const function z_vect_get_nrows(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1033,7 +1333,7 @@ contains end function z_vect_get_nrows function z_vect_get_ncols(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x integer(psb_ipk_) :: res res = 0 @@ -1041,7 +1341,7 @@ contains end function z_vect_get_ncols function z_vect_sizeof(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x integer(psb_epk_) :: res res = 0 @@ -1049,7 +1349,7 @@ contains end function z_vect_sizeof function z_vect_get_fmt(x) result(res) - implicit none + implicit none class(psb_z_multivect_type), intent(in) :: x character(len=5) :: res res = 'NULL' @@ -1058,18 +1358,18 @@ contains subroutine z_vect_all(m,n, x, info, mold) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(out) :: x class(psb_z_base_multivect_type), intent(in), optional :: mold integer(psb_ipk_), intent(out) :: info - if (present(mold)) then + if (present(mold)) then allocate(x%v,stat=info,mold=mold) else allocate(psb_z_base_multivect_type :: x%v,stat=info) endif - if (info == 0) then + if (info == 0) then call x%v%all(m,n,info) else info = psb_err_alloc_dealloc_ @@ -1079,12 +1379,12 @@ contains subroutine z_vect_reall(m,n, x, info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (.not.allocated(x%v)) & & call x%all(m,n,info) if (info == 0) & @@ -1094,7 +1394,7 @@ contains subroutine z_vect_zero(x) use psi_serial_mod - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x if (allocated(x%v)) call x%v%zero() @@ -1104,7 +1404,7 @@ contains subroutine z_vect_asb(m,n, x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -1115,7 +1415,7 @@ contains end subroutine z_vect_asb subroutine z_vect_sync(x) - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x if (allocated(x%v)) & @@ -1183,12 +1483,12 @@ contains subroutine z_vect_free(x, info) use psi_serial_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info info = 0 - if (allocated(x%v)) then + if (allocated(x%v)) then call x%v%free(info) if (info == 0) deallocate(x%v,stat=info) end if @@ -1197,7 +1497,7 @@ contains subroutine z_vect_ins(n,irl,val,dupl,x,info) use psi_serial_mod - implicit none + implicit none class(psb_z_multivect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: n, dupl integer(psb_ipk_), intent(in) :: irl(:) @@ -1207,7 +1507,7 @@ contains integer(psb_ipk_) :: i info = 0 - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ return end if @@ -1223,12 +1523,12 @@ contains class(psb_z_base_multivect_type), allocatable :: tmp integer(psb_ipk_) :: info - if (present(mold)) then + if (present(mold)) then allocate(tmp,stat=info,mold=mold) else allocate(tmp,stat=info, mold=psb_z_get_base_multivect_default()) - endif - if (allocated(x%v)) then + endif + if (allocated(x%v)) then call x%v%sync() if (info == psb_success_) call tmp%bld(x%v%v) call x%v%free(info) @@ -1238,7 +1538,7 @@ contains !!$ function z_vect_dot_v(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x, y !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_dpk_) :: res @@ -1250,28 +1550,28 @@ contains !!$ end function z_vect_dot_v !!$ !!$ function z_vect_dot_a(n,x,y) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ integer(psb_ipk_), intent(in) :: n !!$ complex(psb_dpk_) :: res -!!$ +!!$ !!$ res = zzero !!$ if (allocated(x%v)) & !!$ & res = x%v%dot(n,y) -!!$ +!!$ !!$ end function z_vect_dot_a -!!$ +!!$ !!$ subroutine z_vect_axpby_v(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ complex(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ -!!$ if (allocated(x%v).and.allocated(y%v)) then +!!$ +!!$ if (allocated(x%v).and.allocated(y%v)) then !!$ call y%v%axpby(m,alpha,x%v,beta,info) !!$ else !!$ info = psb_err_invalid_vect_state_ @@ -1281,25 +1581,25 @@ contains !!$ !!$ subroutine z_vect_axpby_a(m,alpha, x, beta, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ integer(psb_ipk_), intent(in) :: m !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ complex(psb_dpk_), intent (in) :: alpha, beta !!$ integer(psb_ipk_), intent(out) :: info -!!$ +!!$ !!$ if (allocated(y%v)) & !!$ & call y%v%axpby(m,alpha,x,beta,info) -!!$ +!!$ !!$ end subroutine z_vect_axpby_a !!$ -!!$ +!!$ !!$ subroutine z_vect_mlt_v(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1310,7 +1610,7 @@ contains !!$ !!$ subroutine z_vect_mlt_a(x, y, info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ integer(psb_ipk_), intent(out) :: info @@ -1320,13 +1620,13 @@ contains !!$ info = 0 !!$ if (allocated(y%v)) & !!$ & call y%v%mlt(x,info) -!!$ +!!$ !!$ end subroutine z_vect_mlt_a !!$ !!$ !!$ subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ complex(psb_dpk_), intent(in) :: x(:) @@ -1334,20 +1634,20 @@ contains !!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ -!!$ info = 0 +!!$ info = 0 !!$ if (allocated(z%v)) & !!$ & call z%v%mlt(alpha,x,y,beta,info) -!!$ +!!$ !!$ end subroutine z_vect_mlt_a_2 !!$ !!$ subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ class(psb_z_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ character(len=1), intent(in), optional :: conjgx, conjgy !!$ !!$ integer(psb_ipk_) :: i, n @@ -1361,12 +1661,12 @@ contains !!$ !!$ subroutine z_vect_mlt_av(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: x(:) !!$ class(psb_z_multivect_type), intent(inout) :: y !!$ class(psb_z_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 @@ -1377,16 +1677,16 @@ contains !!$ !!$ subroutine z_vect_mlt_va(alpha,x,y,beta,z,info) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ complex(psb_dpk_), intent(in) :: alpha,beta !!$ complex(psb_dpk_), intent(in) :: y(:) !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ class(psb_z_multivect_type), intent(inout) :: z -!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_) :: i, n !!$ !!$ info = 0 -!!$ +!!$ !!$ if (allocated(z%v).and.allocated(x%v)) & !!$ & call z%v%mlt(alpha,x%v,y,beta,info) !!$ @@ -1394,36 +1694,36 @@ contains !!$ !!$ subroutine z_vect_scal(alpha, x) !!$ use psi_serial_mod -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ complex(psb_dpk_), intent (in) :: alpha -!!$ +!!$ !!$ if (allocated(x%v)) call x%v%scal(alpha) !!$ !!$ end subroutine z_vect_scal !!$ !!$ !!$ function z_vect_nrm2(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res -!!$ -!!$ if (allocated(x%v)) then +!!$ +!!$ if (allocated(x%v)) then !!$ res = x%v%nrm2(n) !!$ else !!$ res = dzero !!$ end if !!$ !!$ end function z_vect_nrm2 -!!$ +!!$ !!$ function z_vect_amax(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%amax(n) !!$ else !!$ res = dzero @@ -1432,12 +1732,12 @@ contains !!$ end function z_vect_amax !!$ !!$ function z_vect_asum(n,x) result(res) -!!$ implicit none +!!$ implicit none !!$ class(psb_z_multivect_type), intent(inout) :: x !!$ integer(psb_ipk_), intent(in) :: n !!$ real(psb_dpk_) :: res !!$ -!!$ if (allocated(x%v)) then +!!$ if (allocated(x%v)) then !!$ res = x%v%asum(n) !!$ else !!$ res = dzero diff --git a/base/psblas/Makefile b/base/psblas/Makefile index 44eb67ee9..a16ab35cd 100644 --- a/base/psblas/Makefile +++ b/base/psblas/Makefile @@ -9,25 +9,31 @@ OBJS= psb_ddot.o psb_damax.o psb_dasum.o psb_daxpby.o\ psb_saxpby.o psb_sdot.o psb_sasum.o psb_samax.o\ psb_snrm2.o psb_snrmi.o psb_sspmm.o psb_sspsm.o\ psb_camax.o psb_casum.o psb_caxpby.o psb_cdot.o \ - psb_cnrm2.o psb_cnrmi.o psb_cspmm.o psb_cspsm.o - + psb_cnrm2.o psb_cnrmi.o psb_cspmm.o psb_cspsm.o \ + psb_cmlt_vect.o psb_dmlt_vect.o psb_zmlt_vect.o psb_smlt_vect.o\ + psb_cdiv_vect.o psb_ddiv_vect.o psb_zdiv_vect.o psb_sdiv_vect.o\ + psb_cinv_vect.o psb_dinv_vect.o psb_zinv_vect.o psb_sinv_vect.o\ + psb_dcmp_vect.o psb_scmp_vect.o psb_ccmp_vect.o psb_zcmp_vect.o\ + psb_cabs_vect.o psb_dabs_vect.o psb_sabs_vect.o \ + psb_zabs_vect.o psb_cgetmatinfo.o psb_dgetmatinfo.o psb_sgetmatinfo.o \ + psb_zgetmatinfo.o LIBDIR=.. INCDIR=.. MODDIR=../modules -FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) +FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) -lib: $(OBJS) +lib: $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) -#$(F90_PSDOBJS): $(MODS) +#$(F90_PSDOBJS): $(MODS) veryclean: clean /bin/rm -f $(LIBNAME) -clean: +clean: /bin/rm -f $(OBJS) $(LOCAL_MODS) veryclean: clean diff --git a/base/psblas/psb_cabs_vect.f90 b/base/psblas/psb_cabs_vect.f90 new file mode 100644 index 000000000..46e74635b --- /dev/null +++ b/base/psblas/psb_cabs_vect.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cabs_vect + +subroutine psb_cabs_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cabs_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_abs_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%absval(y) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cabs_vect diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index 0de31a0cf..215696139 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_camax.f90 ! ! Function: psb_camax ! Computes the maximum absolute value of X ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N,JX:). ! @@ -77,7 +77,7 @@ function psb_camax(x,desc_a, info, jx,global) result(res) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) - goto 9999 + goto 9999 endif ix = 1 @@ -113,7 +113,7 @@ function psb_camax(x,desc_a, info, jx,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx)) - else + else res = szero end if @@ -121,7 +121,7 @@ function psb_camax(x,desc_a, info, jx,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -131,12 +131,12 @@ end function psb_camax -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -148,7 +148,7 @@ end function psb_camax !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -160,13 +160,13 @@ end function psb_camax !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_camaxv ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x(:) - complex The input vector. @@ -237,7 +237,7 @@ function psb_camaxv (x,desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = szero end if @@ -245,7 +245,7 @@ function psb_camaxv (x,desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -256,7 +256,7 @@ end function psb_camaxv ! Function: psb_camax_vect ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x - type(psb_c_vect_type) The input vector. @@ -302,7 +302,7 @@ function psb_camax_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -335,7 +335,7 @@ function psb_camax_vect(x, desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%amax(desc_a%get_local_rows()) - else + else res = szero end if @@ -343,7 +343,7 @@ function psb_camax_vect(x, desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -352,12 +352,12 @@ function psb_camax_vect(x, desc_a, info,global) result(res) end function psb_camax_vect -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -369,7 +369,7 @@ end function psb_camax_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -381,13 +381,13 @@ end function psb_camax_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_camaxvs ! Computes the maximum absolute value of X, subroutine version ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N). ! @@ -460,7 +460,7 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = szero end if @@ -468,7 +468,7 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -476,12 +476,12 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) end subroutine psb_camaxvs -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -493,7 +493,7 @@ end subroutine psb_camaxvs !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -505,13 +505,13 @@ end subroutine psb_camaxvs !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_cmamaxs ! Searches the absolute max of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! res(:) - real. The result. @@ -596,9 +596,10 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_cmamaxs + diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index daa478293..6518e7301 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_caxpby.f90 ! @@ -46,12 +46,12 @@ ! info - integer Return code ! ! Note: from a functional point of view, X is input, but here -! it's declared INOUT because of the sync() methods. +! it's declared INOUT because of the sync() methods. ! subroutine psb_caxpby_vect(alpha, x, beta, y,& & desc_a, info) use psb_base_mod, psb_protect_name => psb_caxpby_vect - implicit none + implicit none type(psb_c_vect_type), intent (inout) :: x type(psb_c_vect_type), intent (inout) :: y complex(psb_spk_), intent (in) :: alpha, beta @@ -65,7 +65,7 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& character(len=20) :: name, ch_err name='psb_cgeaxpby' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -77,12 +77,12 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -121,7 +121,7 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -129,6 +129,152 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& end subroutine psb_caxpby_vect +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_caxpby.f90 + +! +! Subroutine: psb_caxpby_vect_out +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - complex,input The scalar used to multiply each component of X +! x - type(psb_c_vect_type) The input vector containing the entries of X +! beta - complex,input The scalar used to multiply each component of Y +! y - type(psb_c_vect_type) The input vector Y +! z - type(psb_c_vect_type) The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! Note: from a functional point of view, X is input, but here +! it's declared INOUT because of the sync() methods. +! +subroutine psb_caxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + use psb_base_mod, psb_protect_name => psb_caxpby_vect_out + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + complex(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_cgeaxpby' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call z%axpby(desc_a%get_local_rows(),& + & alpha,x,beta,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_caxpby_vect_out + ! ! Subroutine: psb_caxpby ! Adds one distributed matrix to another, @@ -146,13 +292,13 @@ end subroutine psb_caxpby_vect ! y(:,:) - complex,inout The input vector Y ! desc_a - type(psb_desc_type) The communication descriptor. ! info - integer Return code -! jx - integer(optional) The column offset for X -! jy - integer(optional) The column offset for Y +! jx - integer(optional) The column offset for X +! jy - integer(optional) The column offset for Y ! subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) use psb_base_mod, psb_protect_name => psb_caxpby - implicit none + implicit none integer(psb_ipk_), intent(in), optional :: n, jx, jy integer(psb_ipk_), intent(out) :: info @@ -198,7 +344,7 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) if (present(n)) then if(((ijx+n) <= size(x,2)).and.& - & ((ijy+n) <= size(y,2))) then + & ((ijy+n) <= size(y,2))) then in = n else in = min(size(x,2),size(y,2)) @@ -242,7 +388,7 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -253,12 +399,12 @@ end subroutine psb_caxpby -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -270,7 +416,7 @@ end subroutine psb_caxpby !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -282,8 +428,8 @@ end subroutine psb_caxpby !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_caxpbyv ! Adds one distributed vector to another, @@ -301,7 +447,7 @@ end subroutine psb_caxpby ! subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) use psb_base_mod, psb_protect_name => psb_caxpbyv - implicit none + implicit none integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a @@ -366,9 +512,226 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_caxpbyv + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_caxpbyvout +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - complex,input The scalar used to multiply each component of X +! x(:) - complex,input The input vector containing the entries of X +! beta - complex,input The scalar used to multiply each component of Y +! y(:) - complex,input The input vector Y containing the entries of Y +! Z(:) - complex,inout The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! +subroutine psb_caxpbyvout(alpha, x, beta,y, z, desc_a,info) + use psb_base_mod, psb_protect_name => psb_caxpbyvout + implicit none + + integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), intent(in) :: alpha, beta + complex(psb_spk_), intent(in) :: x(:) + complex(psb_spk_), intent(in) :: y(:) + complex(psb_spk_), intent(inout) :: z(:) + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + lldx = size(x,1) + lldy = size(y,1) + lldz = size(z,1) + ! check vector correctness + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldz,iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call caxpby(desc_a%get_local_cols(),ione,& + & alpha,x,lldx,beta,& + & y,lldy,z,lldz,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_caxpbyvout + +! +! Subroutine: psb_caddconst_vect +! Adds one distributed vector to another, +! +! Z(i) := X(i) + b +! +! Arguments: +! x - type(psb_c_vect_type) The input vector containing the entries of X +! b - complex,input The scalar used to add each component of X +! z - type(psb_c_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_caddconst_vect(x,b,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_caddconst_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_addconst_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%addconst(x,b,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_caddconst_vect diff --git a/base/psblas/psb_ccmp_vect.f90 b/base/psblas/psb_ccmp_vect.f90 new file mode 100644 index 000000000..367f193b6 --- /dev/null +++ b/base/psblas/psb_ccmp_vect.f90 @@ -0,0 +1,217 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_ccmp_vect + +subroutine psb_ccmp_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_ccmp_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_cmp_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%acmp(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ccmp_vect + +subroutine psb_ccmp_spmatval(a,val,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_ccmp_spmatval + implicit none + type(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_ccmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols()))) then + res = .false. + else + res = a%spcmp(val,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_ccmp_spmatval + +subroutine psb_ccmp_spmat(a,b,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_ccmp_spmat + implicit none + type(psb_cspmat_type), intent(inout) :: a + type(psb_cspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_ccmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_rows() == b%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols())& + .and.(desc_a%get_local_cols() == b%get_ncols()))) then + res = .false. + else + res = a%spcmp(b,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ccmp_spmat diff --git a/base/psblas/psb_cdiv_vect.f90 b/base/psblas/psb_cdiv_vect.f90 new file mode 100644 index 000000000..3e709da48 --- /dev/null +++ b/base/psblas/psb_cdiv_vect.f90 @@ -0,0 +1,354 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cdiv_vect + +subroutine psb_cdiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cdiv_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cdiv_vect + +subroutine psb_cdiv_vect2(x,y,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cdiv_vect2 + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_c_div_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cdiv_vect2 + +subroutine psb_cdiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_cdiv_vect_check + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cdiv_vect_check + +subroutine psb_cdiv_vect2_check(x,y,z,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_cdiv_vect2_check + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_c_div_vect2_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cdiv_vect2_check + diff --git a/base/psblas/psb_cgetmatinfo.f90 b/base/psblas/psb_cgetmatinfo.f90 new file mode 100644 index 000000000..9e406c155 --- /dev/null +++ b/base/psblas/psb_cgetmatinfo.f90 @@ -0,0 +1,80 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cgetmatinfo.f90 +! +! This function containts the implementation for obtaining information on the +! paralle sparse matrix +! +function psb_cget_nnz(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_cget_nnz + use psi_mod + use mpi + + implicit none + + integer(psb_lpk_) :: res + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iia, jja + integer(psb_lpk_) :: localnnz + character(len=20) :: name, ch_err + ! + name='psb_cget_nnz' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + localnnz = a%get_nzeros() + + call psb_sum(ictxt,localnnz) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_cinv_vect.f90 b/base/psblas/psb_cinv_vect.f90 new file mode 100644 index 000000000..27f046818 --- /dev/null +++ b/base/psblas/psb_cinv_vect.f90 @@ -0,0 +1,194 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cinv_vect + +subroutine psb_cinv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cinv_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_inv_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cinv_vect + +subroutine psb_cinv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_cinv_vect_check + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + logical :: check + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_inv_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info,flag) + end if + + if (info == 1_psb_ipk_) then + check = .FALSE. + else + check = .TRUE. + end if + + call psb_lallreduceand(ictxt,check) + + if (check) then + info = 1_psb_ipk_ + else + info = 0_psb_ipk_ + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cinv_vect_check diff --git a/base/psblas/psb_cmlt_vect.f90 b/base/psblas/psb_cmlt_vect.f90 new file mode 100644 index 000000000..e2b092709 --- /dev/null +++ b/base/psblas/psb_cmlt_vect.f90 @@ -0,0 +1,198 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cmlt_vect + +subroutine psb_cmlt_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cmlt_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_c_mlt_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%mlt(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cmlt_vect + +! +! Subroutine: psb_cmlt_vect2 +! + +subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_cmlt_vect2 + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_c_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cmlt_vect2 diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index 1db5773a2..d357c9516 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_cnrm2.f90 ! ! Function: psb_cnrm2 @@ -111,7 +111,7 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = scnrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) @@ -120,16 +120,16 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(sone - dd*(abs(x(idx,jjx))/res)**2) + res = res * sqrt(sone - dd*(abs(x(idx,jjx))/res)**2) end do - else + else res = szero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -138,12 +138,12 @@ end function psb_cnrm2 -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -155,7 +155,7 @@ end function psb_cnrm2 !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -167,7 +167,7 @@ end function psb_cnrm2 !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_cnrm2 @@ -226,7 +226,7 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) ix = 1 jx=1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -240,7 +240,7 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = scnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once @@ -248,16 +248,16 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) end do - else + else res = szero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -314,7 +314,7 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -343,7 +343,7 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) ! adjust because overlapped elements are computed more than once @@ -356,27 +356,243 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) end do end if - else + else res = szero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end function psb_cnrm2_vect +! Function: psb_cnrm2_weight_vect +! Computes the weighted norm2 of a distributed vector, +! +! norm2 := sqrt ( (w.*X)**C * (w.*X)) +! +! Arguments: +! x - type(psb_c_vect_type) The input vector containing the entries of X. +! w - type(psb_c_vect_type) The input vector containing the entries of W. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_cnrm2_weight_vect(x,w, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_c_vect_mod + implicit none -!!$ + real(psb_spk_) :: res + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: w + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_spk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_cnrm2v_weight' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = szero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_cnrm2_weight_vect + +! Function: psb_cnrm2_weight_vect +! Computes the weighted norm2 of a distributed vector with respect to a mask +! contained in the vector id. +! +! norm2 := sqrt ( (w(id > 0).*X(id > 0))**C * (w(id > 0).*X(id > 0))) +! +! Arguments: +! x - type(psb_c_vect_type) The input vector containing the entries of X. +! w - type(psb_c_vect_type) The input vector containing the entries of W. +! id - type(psb_c_vect_type) The inpute vector containing the mask +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_cnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_c_vect_mod + implicit none + + real(psb_spk_) :: res + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: w + type(psb_c_vect_type), intent (inout) :: idv + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_spk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_cnrm2v_weightmask' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w,idv) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(cone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = szero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_cnrm2_weightmask_vect + +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -388,7 +604,7 @@ end function psb_cnrm2_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -400,7 +616,7 @@ end function psb_cnrm2_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Subroutine: psb_cnrm2vs @@ -461,7 +677,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) ix = 1 jx = 1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -475,7 +691,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = scnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) @@ -484,9 +700,9 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) end do - else + else res = szero end if @@ -494,7 +710,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) diff --git a/base/psblas/psb_cvmlt.f90 b/base/psblas/psb_cvmlt.f90 new file mode 100644 index 000000000..829ce9873 --- /dev/null +++ b/base/psblas/psb_cvmlt.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cvmlt.f90 + +subroutine psb_cvmlt(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cvmlt + implicit none + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_cgevmlt' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call y%base_mlt_v(desc_a%get_local_rows(),& + & alpha,x,beta,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cvmlt diff --git a/base/psblas/psb_dabs_vect.f90 b/base/psblas/psb_dabs_vect.f90 new file mode 100644 index 000000000..78f2b75cb --- /dev/null +++ b/base/psblas/psb_dabs_vect.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dabs_vect + +subroutine psb_dabs_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dabs_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_abs_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%absval(y) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dabs_vect diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index 0f3ea0b61..ea3581d45 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_damax.f90 ! ! Function: psb_damax ! Computes the maximum absolute value of X ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N,JX:). ! @@ -77,7 +77,7 @@ function psb_damax(x,desc_a, info, jx,global) result(res) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) - goto 9999 + goto 9999 endif ix = 1 @@ -113,7 +113,7 @@ function psb_damax(x,desc_a, info, jx,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx)) - else + else res = dzero end if @@ -121,7 +121,7 @@ function psb_damax(x,desc_a, info, jx,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -131,12 +131,12 @@ end function psb_damax -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -148,7 +148,7 @@ end function psb_damax !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -160,13 +160,13 @@ end function psb_damax !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_damaxv ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x(:) - real The input vector. @@ -237,7 +237,7 @@ function psb_damaxv (x,desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = dzero end if @@ -245,7 +245,7 @@ function psb_damaxv (x,desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -256,7 +256,7 @@ end function psb_damaxv ! Function: psb_damax_vect ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x - type(psb_d_vect_type) The input vector. @@ -302,7 +302,7 @@ function psb_damax_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -335,7 +335,7 @@ function psb_damax_vect(x, desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%amax(desc_a%get_local_rows()) - else + else res = dzero end if @@ -343,7 +343,7 @@ function psb_damax_vect(x, desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -352,12 +352,12 @@ function psb_damax_vect(x, desc_a, info,global) result(res) end function psb_damax_vect -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -369,7 +369,7 @@ end function psb_damax_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -381,13 +381,13 @@ end function psb_damax_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_damaxvs ! Computes the maximum absolute value of X, subroutine version ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N). ! @@ -460,7 +460,7 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = dzero end if @@ -468,7 +468,7 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -476,12 +476,12 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) end subroutine psb_damaxvs -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -493,7 +493,7 @@ end subroutine psb_damaxvs !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -505,13 +505,13 @@ end subroutine psb_damaxvs !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_dmamaxs ! Searches the absolute max of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! res(:) - real. The result. @@ -596,9 +596,108 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_dmamaxs + +! +! Function: psb_dmin_vect +! Computes the minimum value of X. +! +! mini := min(X(i)) +! +! Arguments: +! x - type(psb_d_vect_type) The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! + +function psb_dmin_vect(x, desc_a, info,global) result(res) + use psb_penv_mod + use psb_serial_mod + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_d_vect_mod + implicit none + + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + character(len=20) :: name, ch_err + + name='psb_dmin_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + + m = desc_a%get_global_rows() + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then + res = x%minreal(desc_a%get_local_rows()) + else + res = dzero + end if + + ! compute global min + if (global_) call psb_min(ictxt, res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function psb_dmin_vect diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 73f62881b..550711e4a 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_daxpby.f90 ! @@ -46,12 +46,12 @@ ! info - integer Return code ! ! Note: from a functional point of view, X is input, but here -! it's declared INOUT because of the sync() methods. +! it's declared INOUT because of the sync() methods. ! subroutine psb_daxpby_vect(alpha, x, beta, y,& & desc_a, info) use psb_base_mod, psb_protect_name => psb_daxpby_vect - implicit none + implicit none type(psb_d_vect_type), intent (inout) :: x type(psb_d_vect_type), intent (inout) :: y real(psb_dpk_), intent (in) :: alpha, beta @@ -65,7 +65,7 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& character(len=20) :: name, ch_err name='psb_dgeaxpby' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -77,12 +77,12 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -121,7 +121,7 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -129,6 +129,152 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& end subroutine psb_daxpby_vect +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_daxpby.f90 + +! +! Subroutine: psb_daxpby_vect_out +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - real,input The scalar used to multiply each component of X +! x - type(psb_d_vect_type) The input vector containing the entries of X +! beta - real,input The scalar used to multiply each component of Y +! y - type(psb_d_vect_type) The input vector Y +! z - type(psb_d_vect_type) The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! Note: from a functional point of view, X is input, but here +! it's declared INOUT because of the sync() methods. +! +subroutine psb_daxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + use psb_base_mod, psb_protect_name => psb_daxpby_vect_out + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_dgeaxpby' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call z%axpby(desc_a%get_local_rows(),& + & alpha,x,beta,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_daxpby_vect_out + ! ! Subroutine: psb_daxpby ! Adds one distributed matrix to another, @@ -146,13 +292,13 @@ end subroutine psb_daxpby_vect ! y(:,:) - real,inout The input vector Y ! desc_a - type(psb_desc_type) The communication descriptor. ! info - integer Return code -! jx - integer(optional) The column offset for X -! jy - integer(optional) The column offset for Y +! jx - integer(optional) The column offset for X +! jy - integer(optional) The column offset for Y ! subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) use psb_base_mod, psb_protect_name => psb_daxpby - implicit none + implicit none integer(psb_ipk_), intent(in), optional :: n, jx, jy integer(psb_ipk_), intent(out) :: info @@ -198,7 +344,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) if (present(n)) then if(((ijx+n) <= size(x,2)).and.& - & ((ijy+n) <= size(y,2))) then + & ((ijy+n) <= size(y,2))) then in = n else in = min(size(x,2),size(y,2)) @@ -242,7 +388,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -253,12 +399,12 @@ end subroutine psb_daxpby -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -270,7 +416,7 @@ end subroutine psb_daxpby !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -282,8 +428,8 @@ end subroutine psb_daxpby !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_daxpbyv ! Adds one distributed vector to another, @@ -301,7 +447,7 @@ end subroutine psb_daxpby ! subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) use psb_base_mod, psb_protect_name => psb_daxpbyv - implicit none + implicit none integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a @@ -366,9 +512,226 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_daxpbyv + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_daxpbyvout +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - real,input The scalar used to multiply each component of X +! x(:) - real,input The input vector containing the entries of X +! beta - real,input The scalar used to multiply each component of Y +! y(:) - real,input The input vector Y containing the entries of Y +! Z(:) - real,inout The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! +subroutine psb_daxpbyvout(alpha, x, beta,y, z, desc_a,info) + use psb_base_mod, psb_protect_name => psb_daxpbyvout + implicit none + + integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), intent(in) :: alpha, beta + real(psb_dpk_), intent(in) :: x(:) + real(psb_dpk_), intent(in) :: y(:) + real(psb_dpk_), intent(inout) :: z(:) + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + lldx = size(x,1) + lldy = size(y,1) + lldz = size(z,1) + ! check vector correctness + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldz,iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call daxpby(desc_a%get_local_cols(),ione,& + & alpha,x,lldx,beta,& + & y,lldy,z,lldz,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_daxpbyvout + +! +! Subroutine: psb_daddconst_vect +! Adds one distributed vector to another, +! +! Z(i) := X(i) + b +! +! Arguments: +! x - type(psb_d_vect_type) The input vector containing the entries of X +! b - real,input The scalar used to add each component of X +! z - type(psb_d_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_daddconst_vect(x,b,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_daddconst_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_addconst_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%addconst(x,b,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_daddconst_vect diff --git a/base/psblas/psb_dcmp_vect.f90 b/base/psblas/psb_dcmp_vect.f90 new file mode 100644 index 000000000..084feeda9 --- /dev/null +++ b/base/psblas/psb_dcmp_vect.f90 @@ -0,0 +1,339 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dcmp_vect + +subroutine psb_dcmp_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dcmp_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_cmp_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%acmp(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dcmp_vect + +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dmask_vect + +subroutine psb_dmask_vect(c,x,m,t,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dmask_vect + implicit none + type(psb_d_vect_type), intent (inout) :: c + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: m + logical, intent(out) :: t + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, mm + character(len=20) :: name, ch_err + + name='psb_d_mask_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(c%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(m%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + mm = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(mm,lone,c%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(mm,lone,x%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(mm,lone,m%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call m%mask(c,x,t,info) + end if + + call psb_lallreduceand(ictxt,t) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dmask_vect + + +subroutine psb_dcmp_spmatval(a,val,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_dcmp_spmatval + implicit none + type(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_dcmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols()))) then + res = .false. + else + res = a%spcmp(val,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_dcmp_spmatval + +subroutine psb_dcmp_spmat(a,b,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_dcmp_spmat + implicit none + type(psb_dspmat_type), intent(inout) :: a + type(psb_dspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_dcmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_rows() == b%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols())& + .and.(desc_a%get_local_cols() == b%get_ncols()))) then + res = .false. + else + res = a%spcmp(b,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dcmp_spmat diff --git a/base/psblas/psb_ddiv_vect.f90 b/base/psblas/psb_ddiv_vect.f90 new file mode 100644 index 000000000..d5a85913c --- /dev/null +++ b/base/psblas/psb_ddiv_vect.f90 @@ -0,0 +1,441 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_ddiv_vect + +subroutine psb_ddiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_ddiv_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ddiv_vect + +subroutine psb_ddiv_vect2(x,y,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_ddiv_vect2 + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_d_div_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ddiv_vect2 + +subroutine psb_ddiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_ddiv_vect_check + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ddiv_vect_check + +subroutine psb_ddiv_vect2_check(x,y,z,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_ddiv_vect2_check + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_d_div_vect2_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ddiv_vect2_check + +function psb_dminquotient_vect(x,y,desc_a,info,global) result(res) + use psb_penv_mod + use psb_serial_mod + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_d_vect_mod + implicit none + + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + character(len=20) :: name, ch_err + + name='psb_dminquotient_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + + m = desc_a%get_global_rows() + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then + res = x%minquotient(y,info) + else + res = dzero + end if + + ! compute global min + if (global_) call psb_min(ictxt, res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function psb_dminquotient_vect diff --git a/base/psblas/psb_dgetmatinfo.f90 b/base/psblas/psb_dgetmatinfo.f90 new file mode 100644 index 000000000..2caf8ed43 --- /dev/null +++ b/base/psblas/psb_dgetmatinfo.f90 @@ -0,0 +1,80 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dgetmatinfo.f90 +! +! This function containts the implementation for obtaining information on the +! paralle sparse matrix +! +function psb_dget_nnz(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_dget_nnz + use psi_mod + use mpi + + implicit none + + integer(psb_lpk_) :: res + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iia, jja + integer(psb_lpk_) :: localnnz + character(len=20) :: name, ch_err + ! + name='psb_dget_nnz' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + localnnz = a%get_nzeros() + + call psb_sum(ictxt,localnnz) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_dinv_vect.f90 b/base/psblas/psb_dinv_vect.f90 new file mode 100644 index 000000000..89b25e38f --- /dev/null +++ b/base/psblas/psb_dinv_vect.f90 @@ -0,0 +1,194 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dinv_vect + +subroutine psb_dinv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dinv_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_inv_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dinv_vect + +subroutine psb_dinv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_dinv_vect_check + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + logical :: check + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_inv_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info,flag) + end if + + if (info == 1_psb_ipk_) then + check = .FALSE. + else + check = .TRUE. + end if + + call psb_lallreduceand(ictxt,check) + + if (check) then + info = 1_psb_ipk_ + else + info = 0_psb_ipk_ + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dinv_vect_check diff --git a/base/psblas/psb_dmlt_vect.f90 b/base/psblas/psb_dmlt_vect.f90 new file mode 100644 index 000000000..ac45802f8 --- /dev/null +++ b/base/psblas/psb_dmlt_vect.f90 @@ -0,0 +1,198 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dmlt_vect + +subroutine psb_dmlt_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dmlt_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_d_mlt_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%mlt(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dmlt_vect + +! +! Subroutine: psb_dmlt_vect2 +! + +subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_dmlt_vect2 + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_d_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dmlt_vect2 diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 0845aac48..16b18d916 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_dnrm2.f90 ! ! Function: psb_dnrm2 @@ -111,7 +111,7 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dnrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) @@ -120,16 +120,16 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(done - dd*(abs(x(idx,jjx))/res)**2) + res = res * sqrt(done - dd*(abs(x(idx,jjx))/res)**2) end do - else + else res = dzero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -138,12 +138,12 @@ end function psb_dnrm2 -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -155,7 +155,7 @@ end function psb_dnrm2 !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -167,7 +167,7 @@ end function psb_dnrm2 !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_dnrm2 @@ -226,7 +226,7 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) ix = 1 jx=1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -240,7 +240,7 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once @@ -248,16 +248,16 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(done - dd*(abs(x(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x(idx))/res)**2) end do - else + else res = dzero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -314,7 +314,7 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -343,7 +343,7 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) ! adjust because overlapped elements are computed more than once @@ -356,27 +356,243 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) end do end if - else + else res = dzero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end function psb_dnrm2_vect +! Function: psb_dnrm2_weight_vect +! Computes the weighted norm2 of a distributed vector, +! +! norm2 := sqrt ( (w.*X)**C * (w.*X)) +! +! Arguments: +! x - type(psb_d_vect_type) The input vector containing the entries of X. +! w - type(psb_d_vect_type) The input vector containing the entries of W. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_dnrm2_weight_vect(x,w, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_d_vect_mod + implicit none -!!$ + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: w + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_dpk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_dnrm2v_weight' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = dzero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_dnrm2_weight_vect + +! Function: psb_dnrm2_weight_vect +! Computes the weighted norm2 of a distributed vector with respect to a mask +! contained in the vector id. +! +! norm2 := sqrt ( (w(id > 0).*X(id > 0))**C * (w(id > 0).*X(id > 0))) +! +! Arguments: +! x - type(psb_d_vect_type) The input vector containing the entries of X. +! w - type(psb_d_vect_type) The input vector containing the entries of W. +! id - type(psb_d_vect_type) The inpute vector containing the mask +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_dnrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_d_vect_mod + implicit none + + real(psb_dpk_) :: res + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: w + type(psb_d_vect_type), intent (inout) :: idv + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_dpk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_dnrm2v_weightmask' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w,idv) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(done - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = dzero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_dnrm2_weightmask_vect + +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -388,7 +604,7 @@ end function psb_dnrm2_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -400,7 +616,7 @@ end function psb_dnrm2_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Subroutine: psb_dnrm2vs @@ -461,7 +677,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) ix = 1 jx = 1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -475,7 +691,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) @@ -484,9 +700,9 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(done - dd*(abs(x(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x(idx))/res)**2) end do - else + else res = dzero end if @@ -494,7 +710,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) diff --git a/base/psblas/psb_dvmlt.f90 b/base/psblas/psb_dvmlt.f90 new file mode 100644 index 000000000..ec5325fc9 --- /dev/null +++ b/base/psblas/psb_dvmlt.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dvmlt.f90 + +subroutine psb_dvmlt(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dvmlt + implicit none + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_dgevmlt' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call y%base_mlt_v(desc_a%get_local_rows(),& + & alpha,x,beta,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dvmlt diff --git a/base/psblas/psb_sabs_vect.f90 b/base/psblas/psb_sabs_vect.f90 new file mode 100644 index 000000000..1d4897a90 --- /dev/null +++ b/base/psblas/psb_sabs_vect.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sabs_vect + +subroutine psb_sabs_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sabs_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_abs_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%absval(y) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sabs_vect diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index 174c7a289..30b22fd8a 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_samax.f90 ! ! Function: psb_samax ! Computes the maximum absolute value of X ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N,JX:). ! @@ -77,7 +77,7 @@ function psb_samax(x,desc_a, info, jx,global) result(res) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) - goto 9999 + goto 9999 endif ix = 1 @@ -113,7 +113,7 @@ function psb_samax(x,desc_a, info, jx,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx)) - else + else res = szero end if @@ -121,7 +121,7 @@ function psb_samax(x,desc_a, info, jx,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -131,12 +131,12 @@ end function psb_samax -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -148,7 +148,7 @@ end function psb_samax !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -160,13 +160,13 @@ end function psb_samax !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_samaxv ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x(:) - real The input vector. @@ -237,7 +237,7 @@ function psb_samaxv (x,desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = szero end if @@ -245,7 +245,7 @@ function psb_samaxv (x,desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -256,7 +256,7 @@ end function psb_samaxv ! Function: psb_samax_vect ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x - type(psb_s_vect_type) The input vector. @@ -302,7 +302,7 @@ function psb_samax_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -335,7 +335,7 @@ function psb_samax_vect(x, desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%amax(desc_a%get_local_rows()) - else + else res = szero end if @@ -343,7 +343,7 @@ function psb_samax_vect(x, desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -352,12 +352,12 @@ function psb_samax_vect(x, desc_a, info,global) result(res) end function psb_samax_vect -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -369,7 +369,7 @@ end function psb_samax_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -381,13 +381,13 @@ end function psb_samax_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_samaxvs ! Computes the maximum absolute value of X, subroutine version ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N). ! @@ -460,7 +460,7 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = szero end if @@ -468,7 +468,7 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -476,12 +476,12 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) end subroutine psb_samaxvs -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -493,7 +493,7 @@ end subroutine psb_samaxvs !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -505,13 +505,13 @@ end subroutine psb_samaxvs !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_smamaxs ! Searches the absolute max of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! res(:) - real. The result. @@ -596,9 +596,108 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx,global) if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_smamaxs + +! +! Function: psb_smin_vect +! Computes the minimum value of X. +! +! mini := min(X(i)) +! +! Arguments: +! x - type(psb_s_vect_type) The input vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! + +function psb_smin_vect(x, desc_a, info,global) result(res) + use psb_penv_mod + use psb_serial_mod + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_s_vect_mod + implicit none + + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + character(len=20) :: name, ch_err + + name='psb_smin_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + + m = desc_a%get_global_rows() + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then + res = x%minreal(desc_a%get_local_rows()) + else + res = szero + end if + + ! compute global min + if (global_) call psb_min(ictxt, res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function psb_smin_vect diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index d3f573dca..b264c3b07 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_saxpby.f90 ! @@ -46,12 +46,12 @@ ! info - integer Return code ! ! Note: from a functional point of view, X is input, but here -! it's declared INOUT because of the sync() methods. +! it's declared INOUT because of the sync() methods. ! subroutine psb_saxpby_vect(alpha, x, beta, y,& & desc_a, info) use psb_base_mod, psb_protect_name => psb_saxpby_vect - implicit none + implicit none type(psb_s_vect_type), intent (inout) :: x type(psb_s_vect_type), intent (inout) :: y real(psb_spk_), intent (in) :: alpha, beta @@ -65,7 +65,7 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& character(len=20) :: name, ch_err name='psb_sgeaxpby' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -77,12 +77,12 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -121,7 +121,7 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -129,6 +129,152 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& end subroutine psb_saxpby_vect +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_saxpby.f90 + +! +! Subroutine: psb_saxpby_vect_out +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - real,input The scalar used to multiply each component of X +! x - type(psb_s_vect_type) The input vector containing the entries of X +! beta - real,input The scalar used to multiply each component of Y +! y - type(psb_s_vect_type) The input vector Y +! z - type(psb_s_vect_type) The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! Note: from a functional point of view, X is input, but here +! it's declared INOUT because of the sync() methods. +! +subroutine psb_saxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + use psb_base_mod, psb_protect_name => psb_saxpby_vect_out + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_sgeaxpby' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call z%axpby(desc_a%get_local_rows(),& + & alpha,x,beta,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_saxpby_vect_out + ! ! Subroutine: psb_saxpby ! Adds one distributed matrix to another, @@ -146,13 +292,13 @@ end subroutine psb_saxpby_vect ! y(:,:) - real,inout The input vector Y ! desc_a - type(psb_desc_type) The communication descriptor. ! info - integer Return code -! jx - integer(optional) The column offset for X -! jy - integer(optional) The column offset for Y +! jx - integer(optional) The column offset for X +! jy - integer(optional) The column offset for Y ! subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) use psb_base_mod, psb_protect_name => psb_saxpby - implicit none + implicit none integer(psb_ipk_), intent(in), optional :: n, jx, jy integer(psb_ipk_), intent(out) :: info @@ -198,7 +344,7 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) if (present(n)) then if(((ijx+n) <= size(x,2)).and.& - & ((ijy+n) <= size(y,2))) then + & ((ijy+n) <= size(y,2))) then in = n else in = min(size(x,2),size(y,2)) @@ -242,7 +388,7 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -253,12 +399,12 @@ end subroutine psb_saxpby -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -270,7 +416,7 @@ end subroutine psb_saxpby !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -282,8 +428,8 @@ end subroutine psb_saxpby !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_saxpbyv ! Adds one distributed vector to another, @@ -301,7 +447,7 @@ end subroutine psb_saxpby ! subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) use psb_base_mod, psb_protect_name => psb_saxpbyv - implicit none + implicit none integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a @@ -366,9 +512,226 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_saxpbyv + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_saxpbyvout +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - real,input The scalar used to multiply each component of X +! x(:) - real,input The input vector containing the entries of X +! beta - real,input The scalar used to multiply each component of Y +! y(:) - real,input The input vector Y containing the entries of Y +! Z(:) - real,inout The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! +subroutine psb_saxpbyvout(alpha, x, beta,y, z, desc_a,info) + use psb_base_mod, psb_protect_name => psb_saxpbyvout + implicit none + + integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), intent(in) :: alpha, beta + real(psb_spk_), intent(in) :: x(:) + real(psb_spk_), intent(in) :: y(:) + real(psb_spk_), intent(inout) :: z(:) + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + lldx = size(x,1) + lldy = size(y,1) + lldz = size(z,1) + ! check vector correctness + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldz,iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call saxpby(desc_a%get_local_cols(),ione,& + & alpha,x,lldx,beta,& + & y,lldy,z,lldz,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_saxpbyvout + +! +! Subroutine: psb_saddconst_vect +! Adds one distributed vector to another, +! +! Z(i) := X(i) + b +! +! Arguments: +! x - type(psb_s_vect_type) The input vector containing the entries of X +! b - real,input The scalar used to add each component of X +! z - type(psb_s_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_saddconst_vect(x,b,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_saddconst_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_addconst_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%addconst(x,b,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_saddconst_vect diff --git a/base/psblas/psb_scmp_vect.f90 b/base/psblas/psb_scmp_vect.f90 new file mode 100644 index 000000000..c67cda7c7 --- /dev/null +++ b/base/psblas/psb_scmp_vect.f90 @@ -0,0 +1,339 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_scmp_vect + +subroutine psb_scmp_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_scmp_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: z + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_cmp_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%acmp(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_scmp_vect + +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_smask_vect + +subroutine psb_smask_vect(c,x,m,t,desc_a,info) + use psb_base_mod, psb_protect_name => psb_smask_vect + implicit none + type(psb_s_vect_type), intent (inout) :: c + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: m + logical, intent(out) :: t + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, mm + character(len=20) :: name, ch_err + + name='psb_s_mask_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(c%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(m%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + mm = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(mm,lone,c%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(mm,lone,x%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(mm,lone,m%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call m%mask(c,x,t,info) + end if + + call psb_lallreduceand(ictxt,t) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_smask_vect + + +subroutine psb_scmp_spmatval(a,val,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_scmp_spmatval + implicit none + type(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols()))) then + res = .false. + else + res = a%spcmp(val,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_scmp_spmatval + +subroutine psb_scmp_spmat(a,b,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_scmp_spmat + implicit none + type(psb_sspmat_type), intent(inout) :: a + type(psb_sspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_rows() == b%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols())& + .and.(desc_a%get_local_cols() == b%get_ncols()))) then + res = .false. + else + res = a%spcmp(b,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_scmp_spmat diff --git a/base/psblas/psb_sdiv_vect.f90 b/base/psblas/psb_sdiv_vect.f90 new file mode 100644 index 000000000..2fba3e738 --- /dev/null +++ b/base/psblas/psb_sdiv_vect.f90 @@ -0,0 +1,441 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sdiv_vect + +subroutine psb_sdiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sdiv_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sdiv_vect + +subroutine psb_sdiv_vect2(x,y,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sdiv_vect2 + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_s_div_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sdiv_vect2 + +subroutine psb_sdiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_sdiv_vect_check + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sdiv_vect_check + +subroutine psb_sdiv_vect2_check(x,y,z,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_sdiv_vect2_check + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_s_div_vect2_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sdiv_vect2_check + +function psb_sminquotient_vect(x,y,desc_a,info,global) result(res) + use psb_penv_mod + use psb_serial_mod + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_s_vect_mod + implicit none + + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + character(len=20) :: name, ch_err + + name='psb_sminquotient_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + + m = desc_a%get_global_rows() + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + ! compute local max + if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then + res = x%minquotient(y,info) + else + res = szero + end if + + ! compute global min + if (global_) call psb_min(ictxt, res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end function psb_sminquotient_vect diff --git a/base/psblas/psb_sgetmatinfo.f90 b/base/psblas/psb_sgetmatinfo.f90 new file mode 100644 index 000000000..8888d4db2 --- /dev/null +++ b/base/psblas/psb_sgetmatinfo.f90 @@ -0,0 +1,80 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sgetmatinfo.f90 +! +! This function containts the implementation for obtaining information on the +! paralle sparse matrix +! +function psb_sget_nnz(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_sget_nnz + use psi_mod + use mpi + + implicit none + + integer(psb_lpk_) :: res + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iia, jja + integer(psb_lpk_) :: localnnz + character(len=20) :: name, ch_err + ! + name='psb_sget_nnz' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + localnnz = a%get_nzeros() + + call psb_sum(ictxt,localnnz) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_sinv_vect.f90 b/base/psblas/psb_sinv_vect.f90 new file mode 100644 index 000000000..5666a821b --- /dev/null +++ b/base/psblas/psb_sinv_vect.f90 @@ -0,0 +1,194 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sinv_vect + +subroutine psb_sinv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sinv_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_inv_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sinv_vect + +subroutine psb_sinv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_sinv_vect_check + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + logical :: check + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_inv_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info,flag) + end if + + if (info == 1_psb_ipk_) then + check = .FALSE. + else + check = .TRUE. + end if + + call psb_lallreduceand(ictxt,check) + + if (check) then + info = 1_psb_ipk_ + else + info = 0_psb_ipk_ + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sinv_vect_check diff --git a/base/psblas/psb_smlt_vect.f90 b/base/psblas/psb_smlt_vect.f90 new file mode 100644 index 000000000..8f1623d9b --- /dev/null +++ b/base/psblas/psb_smlt_vect.f90 @@ -0,0 +1,198 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_smlt_vect + +subroutine psb_smlt_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_smlt_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_s_mlt_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%mlt(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_smlt_vect + +! +! Subroutine: psb_smlt_vect2 +! + +subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_smlt_vect2 + implicit none + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_s_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_smlt_vect2 diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index 35260ef77..ab9c56ca6 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_snrm2.f90 ! ! Function: psb_snrm2 @@ -111,7 +111,7 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = snrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) @@ -120,16 +120,16 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(sone - dd*(abs(x(idx,jjx))/res)**2) + res = res * sqrt(sone - dd*(abs(x(idx,jjx))/res)**2) end do - else + else res = szero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -138,12 +138,12 @@ end function psb_snrm2 -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -155,7 +155,7 @@ end function psb_snrm2 !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -167,7 +167,7 @@ end function psb_snrm2 !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_snrm2 @@ -226,7 +226,7 @@ function psb_snrm2v(x, desc_a, info,global) result(res) ix = 1 jx=1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -240,7 +240,7 @@ function psb_snrm2v(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = snrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once @@ -248,16 +248,16 @@ function psb_snrm2v(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) end do - else + else res = szero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -314,7 +314,7 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -343,7 +343,7 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) ! adjust because overlapped elements are computed more than once @@ -356,27 +356,243 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) end do end if - else + else res = szero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end function psb_snrm2_vect +! Function: psb_snrm2_weight_vect +! Computes the weighted norm2 of a distributed vector, +! +! norm2 := sqrt ( (w.*X)**C * (w.*X)) +! +! Arguments: +! x - type(psb_s_vect_type) The input vector containing the entries of X. +! w - type(psb_s_vect_type) The input vector containing the entries of W. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_snrm2_weight_vect(x,w, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_s_vect_mod + implicit none -!!$ + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: w + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_spk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_snrm2v_weight' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = szero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_snrm2_weight_vect + +! Function: psb_snrm2_weight_vect +! Computes the weighted norm2 of a distributed vector with respect to a mask +! contained in the vector id. +! +! norm2 := sqrt ( (w(id > 0).*X(id > 0))**C * (w(id > 0).*X(id > 0))) +! +! Arguments: +! x - type(psb_s_vect_type) The input vector containing the entries of X. +! w - type(psb_s_vect_type) The input vector containing the entries of W. +! id - type(psb_s_vect_type) The inpute vector containing the mask +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_snrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_s_vect_mod + implicit none + + real(psb_spk_) :: res + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: w + type(psb_s_vect_type), intent (inout) :: idv + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_spk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_snrm2v_weightmask' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w,idv) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(sone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = szero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_snrm2_weightmask_vect + +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -388,7 +604,7 @@ end function psb_snrm2_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -400,7 +616,7 @@ end function psb_snrm2_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Subroutine: psb_snrm2vs @@ -461,7 +677,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) ix = 1 jx = 1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -475,7 +691,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = snrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) @@ -484,9 +700,9 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) + res = res * sqrt(sone - dd*(abs(x(idx))/res)**2) end do - else + else res = szero end if @@ -494,7 +710,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) diff --git a/base/psblas/psb_svmlt.f90 b/base/psblas/psb_svmlt.f90 new file mode 100644 index 000000000..cfe09de1b --- /dev/null +++ b/base/psblas/psb_svmlt.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_svmlt.f90 + +subroutine psb_svmlt(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_svmlt + implicit none + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_sgevmlt' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call y%base_mlt_v(desc_a%get_local_rows(),& + & alpha,x,beta,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_svmlt diff --git a/base/psblas/psb_zabs_vect.f90 b/base/psblas/psb_zabs_vect.f90 new file mode 100644 index 000000000..86ac6bfb7 --- /dev/null +++ b/base/psblas/psb_zabs_vect.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zabs_vect + +subroutine psb_zabs_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zabs_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_abs_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%absval(y) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zabs_vect diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index 5e7680235..8fd10043a 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,14 +27,14 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_zamax.f90 ! ! Function: psb_zamax ! Computes the maximum absolute value of X ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N,JX:). ! @@ -77,7 +77,7 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) if (np == -1) then info = psb_err_context_error_ call psb_errpush(info,name) - goto 9999 + goto 9999 endif ix = 1 @@ -113,7 +113,7 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x(:,jjx)) - else + else res = dzero end if @@ -121,7 +121,7 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -131,12 +131,12 @@ end function psb_zamax -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -148,7 +148,7 @@ end function psb_zamax !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -160,13 +160,13 @@ end function psb_zamax !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_zamaxv ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x(:) - complex The input vector. @@ -237,7 +237,7 @@ function psb_zamaxv (x,desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = dzero end if @@ -245,7 +245,7 @@ function psb_zamaxv (x,desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -256,7 +256,7 @@ end function psb_zamaxv ! Function: psb_zamax_vect ! Computes the maximum absolute value of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! x - type(psb_z_vect_type) The input vector. @@ -302,7 +302,7 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -335,7 +335,7 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = x%amax(desc_a%get_local_rows()) - else + else res = dzero end if @@ -343,7 +343,7 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -352,12 +352,12 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) end function psb_zamax_vect -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -369,7 +369,7 @@ end function psb_zamax_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -381,13 +381,13 @@ end function psb_zamax_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_zamaxvs ! Computes the maximum absolute value of X, subroutine version ! -! normi := max(abs(sub(X)(i)) +! normi := max(abs(sub(X)(i)) ! ! where sub( X ) denotes X(1:N). ! @@ -460,7 +460,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) ! compute local max if ((desc_a%get_local_rows() > 0).and.(m /= 0)) then res = psb_amax(desc_a%get_local_rows()-iix+1,x) - else + else res = dzero end if @@ -468,7 +468,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) if (global_) call psb_amx(ictxt, res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -476,12 +476,12 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) end subroutine psb_zamaxvs -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -493,7 +493,7 @@ end subroutine psb_zamaxvs !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -505,13 +505,13 @@ end subroutine psb_zamaxvs !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_zmamaxs ! Searches the absolute max of X. ! -! normi := max(abs(X(i)) +! normi := max(abs(X(i)) ! ! Arguments: ! res(:) - real. The result. @@ -596,9 +596,10 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) if (global_) call psb_amx(ictxt, res(1:k)) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_zmamaxs + diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index b48bb5ff2..c0cf79fd8 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_zaxpby.f90 ! @@ -46,12 +46,12 @@ ! info - integer Return code ! ! Note: from a functional point of view, X is input, but here -! it's declared INOUT because of the sync() methods. +! it's declared INOUT because of the sync() methods. ! subroutine psb_zaxpby_vect(alpha, x, beta, y,& & desc_a, info) use psb_base_mod, psb_protect_name => psb_zaxpby_vect - implicit none + implicit none type(psb_z_vect_type), intent (inout) :: x type(psb_z_vect_type), intent (inout) :: y complex(psb_dpk_), intent (in) :: alpha, beta @@ -65,7 +65,7 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& character(len=20) :: name, ch_err name='psb_zgeaxpby' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) @@ -77,12 +77,12 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -121,7 +121,7 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -129,6 +129,152 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& end subroutine psb_zaxpby_vect +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zaxpby.f90 + +! +! Subroutine: psb_zaxpby_vect_out +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - complex,input The scalar used to multiply each component of X +! x - type(psb_z_vect_type) The input vector containing the entries of X +! beta - complex,input The scalar used to multiply each component of Y +! y - type(psb_z_vect_type) The input vector Y +! z - type(psb_z_vect_type) The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! Note: from a functional point of view, X is input, but here +! it's declared INOUT because of the sync() methods. +! +subroutine psb_zaxpby_vect_out(alpha, x, beta, y,& + & z, desc_a, info) + use psb_base_mod, psb_protect_name => psb_zaxpby_vect_out + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + complex(psb_dpk_), intent (in) :: alpha, beta + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_zgeaxpby' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call z%axpby(desc_a%get_local_rows(),& + & alpha,x,beta,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zaxpby_vect_out + ! ! Subroutine: psb_zaxpby ! Adds one distributed matrix to another, @@ -146,13 +292,13 @@ end subroutine psb_zaxpby_vect ! y(:,:) - complex,inout The input vector Y ! desc_a - type(psb_desc_type) The communication descriptor. ! info - integer Return code -! jx - integer(optional) The column offset for X -! jy - integer(optional) The column offset for Y +! jx - integer(optional) The column offset for X +! jy - integer(optional) The column offset for Y ! subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) use psb_base_mod, psb_protect_name => psb_zaxpby - implicit none + implicit none integer(psb_ipk_), intent(in), optional :: n, jx, jy integer(psb_ipk_), intent(out) :: info @@ -198,7 +344,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) if (present(n)) then if(((ijx+n) <= size(x,2)).and.& - & ((ijy+n) <= size(y,2))) then + & ((ijy+n) <= size(y,2))) then in = n else in = min(size(x,2),size(y,2)) @@ -242,7 +388,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -253,12 +399,12 @@ end subroutine psb_zaxpby -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -270,7 +416,7 @@ end subroutine psb_zaxpby !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -282,8 +428,8 @@ end subroutine psb_zaxpby !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ +!!$ +!!$ ! ! Subroutine: psb_zaxpbyv ! Adds one distributed vector to another, @@ -301,7 +447,7 @@ end subroutine psb_zaxpby ! subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) use psb_base_mod, psb_protect_name => psb_zaxpbyv - implicit none + implicit none integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(in) :: desc_a @@ -366,9 +512,226 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end subroutine psb_zaxpbyv + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_zaxpbyvout +! Adds one distributed vector to another, +! +! Z := beta * Y + alpha * X +! +! Arguments: +! alpha - complex,input The scalar used to multiply each component of X +! x(:) - complex,input The input vector containing the entries of X +! beta - complex,input The scalar used to multiply each component of Y +! y(:) - complex,input The input vector Y containing the entries of Y +! Z(:) - complex,inout The output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +! +subroutine psb_zaxpbyvout(alpha, x, beta,y, z, desc_a,info) + use psb_base_mod, psb_protect_name => psb_zaxpbyvout + implicit none + + integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), intent(in) :: alpha, beta + complex(psb_dpk_), intent(in) :: x(:) + complex(psb_dpk_), intent(in) :: y(:) + complex(psb_dpk_), intent(inout) :: z(:) + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz, lldx, lldy, lldz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + lldx = size(x,1) + lldy = size(y,1) + lldz = size(z,1) + ! check vector correctness + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,lldz,iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione).or.(iiz /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call zaxpby(desc_a%get_local_cols(),ione,& + & alpha,x,lldx,beta,& + & y,lldy,z,lldz,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_zaxpbyvout + +! +! Subroutine: psb_zaddconst_vect +! Adds one distributed vector to another, +! +! Z(i) := X(i) + b +! +! Arguments: +! x - type(psb_z_vect_type) The input vector containing the entries of X +! b - complex,input The scalar used to add each component of X +! z - type(psb_z_vect_type) The input/output vector Z +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_zaddconst_vect(x,b,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zaddconst_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: b + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_addconst_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%addconst(x,b,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zaddconst_vect diff --git a/base/psblas/psb_zcmp_vect.f90 b/base/psblas/psb_zcmp_vect.f90 new file mode 100644 index 000000000..d0184d09d --- /dev/null +++ b/base/psblas/psb_zcmp_vect.f90 @@ -0,0 +1,217 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zcmp_vect + +subroutine psb_zcmp_vect(x,c,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zcmp_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: z + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_cmp_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%acmp(x,c,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zcmp_vect + +subroutine psb_zcmp_spmatval(a,val,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_zcmp_spmatval + implicit none + type(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_zcmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols()))) then + res = .false. + else + res = a%spcmp(val,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psb_zcmp_spmatval + +subroutine psb_zcmp_spmat(a,b,tol,desc_a,res,info) + use psb_base_mod, psb_protect_name => psb_zcmp_spmat + implicit none + type(psb_zspmat_type), intent(inout) :: a + type(psb_zspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(out) :: res + + ! Local + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_zcmp_spmatval' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.((desc_a%get_local_rows() == a%get_nrows())& + .and.(desc_a%get_local_rows() == b%get_nrows())& + .and.(desc_a%get_local_cols() == a%get_ncols())& + .and.(desc_a%get_local_cols() == b%get_ncols()))) then + res = .false. + else + res = a%spcmp(b,tol,info) + end if + + call psb_lallreduceand(ictxt,res) + + + call psb_erractionrestore(err_act) + if (debug_level >= psb_debug_comp_) then + call psb_barrier(ictxt) + write(debug_unit,*) me,' ',trim(name),' Returning ' + endif + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zcmp_spmat diff --git a/base/psblas/psb_zdiv_vect.f90 b/base/psblas/psb_zdiv_vect.f90 new file mode 100644 index 000000000..f07f5d003 --- /dev/null +++ b/base/psblas/psb_zdiv_vect.f90 @@ -0,0 +1,354 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zdiv_vect + +subroutine psb_zdiv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zdiv_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_div_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zdiv_vect + +subroutine psb_zdiv_vect2(x,y,z,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zdiv_vect2 + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_z_div_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zdiv_vect2 + +subroutine psb_zdiv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_zdiv_vect_check + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_div_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%div(y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zdiv_vect_check + +subroutine psb_zdiv_vect2_check(x,y,z,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_zdiv_vect2_check + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_z_div_vect2_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%div(x,y,info,flag) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zdiv_vect2_check + diff --git a/base/psblas/psb_zgetmatinfo.f90 b/base/psblas/psb_zgetmatinfo.f90 new file mode 100644 index 000000000..7d18418b3 --- /dev/null +++ b/base/psblas/psb_zgetmatinfo.f90 @@ -0,0 +1,80 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zgetmatinfo.f90 +! +! This function containts the implementation for obtaining information on the +! paralle sparse matrix +! +function psb_zget_nnz(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_zget_nnz + use psi_mod + use mpi + + implicit none + + integer(psb_lpk_) :: res + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iia, jja + integer(psb_lpk_) :: localnnz + character(len=20) :: name, ch_err + ! + name='psb_zget_nnz' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + localnnz = a%get_nzeros() + + call psb_sum(ictxt,localnnz) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_zinv_vect.f90 b/base/psblas/psb_zinv_vect.f90 new file mode 100644 index 000000000..bb37ee69b --- /dev/null +++ b/base/psblas/psb_zinv_vect.f90 @@ -0,0 +1,194 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zinv_vect + +subroutine psb_zinv_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zinv_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_inv_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zinv_vect + +subroutine psb_zinv_vect_check(x,y,desc_a,info,flag) + use psb_base_mod, psb_protect_name => psb_zinv_vect_check + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in) :: flag + logical :: check + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_inv_vect_check' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%inv(x,info,flag) + end if + + if (info == 1_psb_ipk_) then + check = .FALSE. + else + check = .TRUE. + end if + + call psb_lallreduceand(ictxt,check) + + if (check) then + info = 1_psb_ipk_ + else + info = 0_psb_ipk_ + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zinv_vect_check diff --git a/base/psblas/psb_zmlt_vect.f90 b/base/psblas/psb_zmlt_vect.f90 new file mode 100644 index 000000000..598a12a72 --- /dev/null +++ b/base/psblas/psb_zmlt_vect.f90 @@ -0,0 +1,198 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zmlt_vect + +subroutine psb_zmlt_vect(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zmlt_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_z_mlt_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call y%mlt(x,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zmlt_vect + +! +! Subroutine: psb_zmlt_vect2 +! + +subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_zmlt_vect2 + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_z_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zmlt_vect2 diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index 9f3277737..bfa29d182 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! File: psb_znrm2.f90 ! ! Function: psb_znrm2 @@ -111,7 +111,7 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dznrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) @@ -120,16 +120,16 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(done - dd*(abs(x(idx,jjx))/res)**2) + res = res * sqrt(done - dd*(abs(x(idx,jjx))/res)**2) end do - else + else res = dzero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -138,12 +138,12 @@ end function psb_znrm2 -!!$ +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -155,7 +155,7 @@ end function psb_znrm2 !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -167,7 +167,7 @@ end function psb_znrm2 !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Function: psb_znrm2 @@ -226,7 +226,7 @@ function psb_znrm2v(x, desc_a, info,global) result(res) ix = 1 jx=1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -240,7 +240,7 @@ function psb_znrm2v(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dznrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once @@ -248,16 +248,16 @@ function psb_znrm2v(x, desc_a, info,global) result(res) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(done - dd*(abs(x(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x(idx))/res)**2) end do - else + else res = dzero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) @@ -314,7 +314,7 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 @@ -343,7 +343,7 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = x%nrm2(ndim) ! adjust because overlapped elements are computed more than once @@ -356,27 +356,243 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) end do end if - else + else res = dzero end if if (global_) call psb_nrm2(ictxt,res) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) return end function psb_znrm2_vect +! Function: psb_znrm2_weight_vect +! Computes the weighted norm2 of a distributed vector, +! +! norm2 := sqrt ( (w.*X)**C * (w.*X)) +! +! Arguments: +! x - type(psb_z_vect_type) The input vector containing the entries of X. +! w - type(psb_z_vect_type) The input vector containing the entries of W. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_znrm2_weight_vect(x,w, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_z_vect_mod + implicit none -!!$ + real(psb_dpk_) :: res + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: w + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_dpk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_znrm2v_weight' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = dzero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_znrm2_weight_vect + +! Function: psb_znrm2_weight_vect +! Computes the weighted norm2 of a distributed vector with respect to a mask +! contained in the vector id. +! +! norm2 := sqrt ( (w(id > 0).*X(id > 0))**C * (w(id > 0).*X(id > 0))) +! +! Arguments: +! x - type(psb_z_vect_type) The input vector containing the entries of X. +! w - type(psb_z_vect_type) The input vector containing the entries of W. +! id - type(psb_z_vect_type) The inpute vector containing the mask +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! global - logical(optional) Whether to perform the global reduction, default: .true. +! +function psb_znrm2_weightmask_vect(x,w,idv, desc_a, info,global) result(res) + use psb_desc_mod + use psb_check_mod + use psb_error_mod + use psb_penv_mod + use psb_z_vect_mod + implicit none + + real(psb_dpk_) :: res + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: w + type(psb_z_vect_type), intent (inout) :: idv + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: global + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m + logical :: global_ + real(psb_dpk_) :: snrm2, dd + character(len=20) :: name, ch_err + + name='psb_znrm2v_weightmask' + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(global)) then + global_ = global + else + global_ = .true. + end if + + ix = 1 + jx = 1 + m = desc_a%get_global_rows() + ldx = x%get_nrows() + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + if (desc_a%get_local_rows() > 0) then + ndim = desc_a%get_local_rows() + res = x%nrm2(ndim,w,idv) + ! adjust because overlapped elements are computed more than once + if (size(desc_a%ovrlap_elem,1)>0) then + if (x%is_dev()) call x%sync() + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + dd = dble(ndm-1)/dble(ndm) + res = res - sqrt(zone - dd*(abs(x%v%v(idx))/res)**2) + end do + end if + else + res = dzero + end if + + if (global_) call psb_nrm2(ictxt,res) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function psb_znrm2_weightmask_vect + +!!$ !!$ Parallel Sparse BLAS version 3.5 !!$ (C) Copyright 2006-2018 !!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ +!!$ Alfredo Buttari +!!$ !!$ Redistribution and use in source and binary forms, with or without !!$ modification, are permitted provided that the following conditions !!$ are met: @@ -388,7 +604,7 @@ end function psb_znrm2_vect !!$ 3. The name of the PSBLAS group or the names of its contributors may !!$ not be used to endorse or promote products derived from this !!$ software without specific written permission. -!!$ +!!$ !!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS !!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED !!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -400,7 +616,7 @@ end function psb_znrm2_vect !!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) !!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE !!$ POSSIBILITY OF SUCH DAMAGE. -!!$ +!!$ !!$ ! ! Subroutine: psb_znrm2vs @@ -461,7 +677,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) ix = 1 jx = 1 m = desc_a%get_global_rows() - ldx = size(x,1) + ldx = size(x,1) call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ @@ -475,7 +691,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) goto 9999 end if - if (desc_a%get_local_rows() > 0) then + if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() res = dznrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) @@ -484,9 +700,9 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) idx = desc_a%ovrlap_elem(i,1) ndm = desc_a%ovrlap_elem(i,2) dd = real(ndm-1)/real(ndm) - res = res * sqrt(done - dd*(abs(x(idx))/res)**2) + res = res * sqrt(done - dd*(abs(x(idx))/res)**2) end do - else + else res = dzero end if @@ -494,7 +710,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(ictxt,err_act) diff --git a/base/psblas/psb_zvmlt.f90 b/base/psblas/psb_zvmlt.f90 new file mode 100644 index 000000000..01a6fc68e --- /dev/null +++ b/base/psblas/psb_zvmlt.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zvmlt.f90 + +subroutine psb_zvmlt(x,y,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zvmlt + implicit none + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=20) :: name, ch_err + + name='psb_zgevmlt' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((iix /= ione).or.(iiy /= ione)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + if(desc_a%get_local_rows() > 0) then + call y%base_mlt_v(desc_a%get_local_rows(),& + & alpha,x,beta,info) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zvmlt diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 879638bf6..6d7824be0 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == ================================== ! ! @@ -45,7 +45,7 @@ subroutine psb_c_base_cp_to_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -69,7 +69,7 @@ subroutine psb_c_base_cp_from_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -94,7 +94,7 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -103,10 +103,10 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -117,12 +117,12 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -136,7 +136,7 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -148,10 +148,10 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_c_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -160,8 +160,8 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -181,7 +181,7 @@ subroutine psb_c_base_mv_to_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -193,17 +193,17 @@ subroutine psb_c_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -218,7 +218,7 @@ subroutine psb_c_base_mv_from_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -229,17 +229,17 @@ subroutine psb_c_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -255,7 +255,7 @@ subroutine psb_c_base_mv_to_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -267,7 +267,7 @@ subroutine psb_c_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_c_coo_sparse_mat) @@ -285,7 +285,7 @@ subroutine psb_c_base_mv_from_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ subroutine psb_c_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_c_coo_sparse_mat) @@ -313,23 +313,23 @@ end subroutine psb_c_base_mv_from_fmt subroutine psb_c_base_clean_zeros(a, info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_clean_zeros - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_c_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_c_base_clean_zeros -subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_a - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -350,11 +350,11 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_c_base_csput_a -subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_v use psb_c_base_vect_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -366,24 +366,24 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() if (ia%is_dev()) call ia%sync() if (ja%is_dev()) call ja%sync() - call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -395,7 +395,7 @@ end subroutine psb_c_base_csput_v subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csgetrow @@ -433,7 +433,7 @@ end subroutine psb_c_base_csgetrow ! subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csgetblk @@ -456,22 +456,22 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -486,19 +486,19 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'c_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -526,7 +526,7 @@ end subroutine psb_c_base_csgetblk subroutine psb_c_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csclip @@ -547,46 +547,46 @@ subroutine psb_c_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -615,7 +615,7 @@ end subroutine psb_c_base_csclip ! subroutine psb_c_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_tril @@ -627,8 +627,8 @@ subroutine psb_c_base_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_c_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_spk_), allocatable :: val(:) @@ -640,51 +640,51 @@ subroutine psb_c_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -716,7 +716,7 @@ subroutine psb_c_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -724,8 +724,8 @@ subroutine psb_c_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -738,7 +738,7 @@ subroutine psb_c_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -747,8 +747,8 @@ subroutine psb_c_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -766,7 +766,7 @@ end subroutine psb_c_base_tril subroutine psb_c_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_triu @@ -778,7 +778,7 @@ subroutine psb_c_base_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_c_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) @@ -791,57 +791,57 @@ subroutine psb_c_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -874,13 +874,13 @@ subroutine psb_c_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -888,7 +888,7 @@ subroutine psb_c_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -897,8 +897,8 @@ subroutine psb_c_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -919,45 +919,45 @@ end subroutine psb_c_base_triu subroutine psb_c_base_clone(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_c_base_clone subroutine psb_c_base_make_nonunit(a) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: i, j, m, n, nz, mnm, info - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + integer(psb_ipk_) :: i, j, m, n, nz, mnm, info + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -974,10 +974,10 @@ subroutine psb_c_base_make_nonunit(a) end subroutine psb_c_base_make_nonunit -subroutine psb_c_base_mold(a,b,info) +subroutine psb_c_base_mold(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mold use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -999,7 +999,7 @@ end subroutine psb_c_base_mold subroutine psb_c_base_transp_2mat(a,b) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1019,11 +1019,11 @@ subroutine psb_c_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1035,7 +1035,7 @@ end subroutine psb_c_base_transp_2mat subroutine psb_c_base_transc_2mat(a,b) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transc_2mat - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1055,11 +1055,11 @@ subroutine psb_c_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1071,7 +1071,7 @@ end subroutine psb_c_base_transc_2mat subroutine psb_c_base_transp_1mat(a) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a @@ -1085,12 +1085,12 @@ subroutine psb_c_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1102,7 +1102,7 @@ end subroutine psb_c_base_transp_1mat subroutine psb_c_base_transc_1mat(a) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transc_1mat - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a @@ -1116,12 +1116,12 @@ subroutine psb_c_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1145,11 +1145,11 @@ end subroutine psb_c_base_transc_1mat ! ! == ================================== -subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmm use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1172,10 +1172,10 @@ subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_c_base_csmm -subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csmv use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1199,10 +1199,10 @@ subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_c_base_csmv -subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_cssm use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1225,10 +1225,10 @@ subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) end subroutine psb_c_base_inner_cssm -subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_cssv use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1251,11 +1251,11 @@ subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) end subroutine psb_c_base_inner_cssv -subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cssm use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1271,7 +1271,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1291,42 +1291,42 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) + tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ @@ -1334,21 +1334,21 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(cone,x,czero,tmp,info,trans) - if (info == psb_success_)then + if (info == psb_success_)then do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) + tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if @@ -1357,13 +1357,13 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -1378,11 +1378,11 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_c_base_cssm -subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cssv use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1418,58 +1418,58 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == czero) then + if (beta == czero) then call a%inner_spsm(alpha,x,czero,y,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,y) else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,czero,tmp,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,tmp) if (info == psb_success_)& & call psb_geaxpby(nar,cone,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1479,13 +1479,13 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1500,37 +1500,37 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return contains subroutine inner_vscal(n,d,x,y) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n complex(psb_spk_), intent(in) :: d(*),x(*) complex(psb_spk_), intent(out) :: y(*) integer(psb_ipk_) :: i do i=1,n - y(i) = d(i)*x(i) + y(i) = d(i)*x(i) end do end subroutine inner_vscal subroutine inner_vscal1(n,d,x) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n complex(psb_spk_), intent(in) :: d(*) complex(psb_spk_), intent(inout) :: x(*) integer(psb_ipk_) :: i do i=1,n - x(i) = d(i)*x(i) + x(i) = d(i)*x(i) end do end subroutine inner_vscal1 end subroutine psb_c_base_cssv -subroutine psb_c_base_scals(d,a,info) +subroutine psb_c_base_scals(d,a,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scals use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1550,12 +1550,55 @@ subroutine psb_c_base_scals(d,a,info) end subroutine psb_c_base_scals +subroutine psb_c_base_scalplusidentity(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: acoo -subroutine psb_c_base_scal(d,a,info,side) + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_scalplusidentity + +subroutine psb_c_base_scal(d,a,info,side) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_scal use psb_error_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1581,7 +1624,7 @@ function psb_c_base_maxval(a) result(res) use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_maxval - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1608,27 +1651,27 @@ function psb_c_base_csnmi(a) result(res) use psb_realloc_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csnmi - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1646,27 +1689,27 @@ function psb_c_base_csnm1(a) result(res) use psb_realloc_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csnm1 - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1678,7 +1721,7 @@ function psb_c_base_csnm1(a) result(res) end function psb_c_base_csnm1 -subroutine psb_c_base_rowsum(d,a) +subroutine psb_c_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_rowsum @@ -1700,7 +1743,7 @@ subroutine psb_c_base_rowsum(d,a) end subroutine psb_c_base_rowsum -subroutine psb_c_base_arwsum(d,a) +subroutine psb_c_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_arwsum @@ -1722,7 +1765,7 @@ subroutine psb_c_base_arwsum(d,a) end subroutine psb_c_base_arwsum -subroutine psb_c_base_colsum(d,a) +subroutine psb_c_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_colsum @@ -1744,7 +1787,7 @@ subroutine psb_c_base_colsum(d,a) end subroutine psb_c_base_colsum -subroutine psb_c_base_aclsum(d,a) +subroutine psb_c_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_aclsum @@ -1766,12 +1809,12 @@ subroutine psb_c_base_aclsum(d,a) end subroutine psb_c_base_aclsum -subroutine psb_c_base_get_diag(a,d,info) +subroutine psb_c_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_get_diag - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1791,15 +1834,153 @@ subroutine psb_c_base_get_diag(a,d,info) end subroutine psb_c_base_get_diag +subroutine psb_c_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_spaxpby + + complex(psb_spk_), intent(in) :: alpha + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: beta + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_c_base_spaxpby + +function psb_c_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cmpval + + class(psb_c_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_c_base_cmpval + +function psb_c_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cmpmat + + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_c_base_cmpmat ! == ================================== ! ! ! ! Computational routines for c_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! +! variables. If the actual data type is +! a "normal" one, these are sufficient. +! ! ! ! @@ -1807,11 +1988,11 @@ end subroutine psb_c_base_get_diag -subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_base_vect_mv - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x @@ -1820,7 +2001,7 @@ subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans ! For the time being we just throw everything back - ! onto the normal routines. + ! onto the normal routines. call x%sync() call y%sync() call a%spmm(alpha,x%v,beta,y%v,info,trans) @@ -1832,7 +2013,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_c_base_vect_mod use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x,y @@ -1869,54 +2050,54 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - call x%sync() + call x%sync() call y%sync() - if (present(d)) then + if (present(d)) then call d%sync() - if (present(scale)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(cone,d%v(1:nac),x,czero,info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call tmpv%mlt(cone,d%v(1:nac),x,czero,info) if (info == psb_success_)& & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - if (info == psb_success_) then + if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == czero) then + if (beta == czero) then call a%inner_spsm(alpha,x,czero,y,info,trans) if (info == psb_success_) call y%mlt(d%v(1:nar),info) else allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,czero,tmpv,info,trans) @@ -1925,7 +2106,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) & call y%axpby(nar,cone,tmpv,beta,info) if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1935,13 +2116,13 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1958,12 +2139,12 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_c_base_vect_cssv -subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_inner_vect_sv use psb_error_mod use psb_string_mod use psb_c_base_vect_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x, y @@ -1977,10 +2158,10 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) + call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1988,7 +2169,7 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return @@ -2000,7 +2181,7 @@ subroutine psb_c_base_cp_to_lcoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2009,22 +2190,22 @@ subroutine psb_c_base_cp_to_lcoo(a,b,info) character(len=20) :: name='to_lcoo' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_lcoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2038,7 +2219,7 @@ subroutine psb_c_base_cp_from_lcoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2047,22 +2228,22 @@ subroutine psb_c_base_cp_from_lcoo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_lcoo(b,info) + call tmp%cp_from_lcoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2076,7 +2257,7 @@ subroutine psb_c_base_cp_to_lfmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2086,10 +2267,10 @@ subroutine psb_c_base_cp_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: icoo type(psb_lc_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2102,12 +2283,12 @@ subroutine psb_c_base_cp_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2121,7 +2302,7 @@ subroutine psb_c_base_cp_from_lfmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2133,10 +2314,10 @@ subroutine psb_c_base_cp_from_lfmt(a,b,info) type(psb_lc_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_lc_coo_sparse_mat) call a%cp_from_lcoo(b,info) @@ -2146,8 +2327,8 @@ subroutine psb_c_base_cp_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2166,7 +2347,7 @@ subroutine psb_c_base_mv_to_lcoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2178,17 +2359,17 @@ subroutine psb_c_base_mv_to_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2202,7 +2383,7 @@ subroutine psb_c_base_mv_from_lcoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2213,17 +2394,17 @@ subroutine psb_c_base_mv_from_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2238,7 +2419,7 @@ subroutine psb_c_base_mv_to_lfmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2248,10 +2429,10 @@ subroutine psb_c_base_mv_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: icoo type(psb_lc_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2264,12 +2445,12 @@ subroutine psb_c_base_mv_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2283,7 +2464,7 @@ subroutine psb_c_base_mv_from_lfmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2295,10 +2476,10 @@ subroutine psb_c_base_mv_from_lfmt(a,b,info) type(psb_lc_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_lc_coo_sparse_mat) call a%mv_from_lcoo(b,info) @@ -2308,8 +2489,8 @@ subroutine psb_c_base_mv_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2343,7 +2524,7 @@ subroutine psb_lc_base_cp_to_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2367,7 +2548,7 @@ subroutine psb_lc_base_cp_from_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2392,7 +2573,7 @@ subroutine psb_lc_base_cp_to_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2401,10 +2582,10 @@ subroutine psb_lc_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_lc_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2415,12 +2596,12 @@ subroutine psb_lc_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2434,7 +2615,7 @@ subroutine psb_lc_base_cp_from_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2446,10 +2627,10 @@ subroutine psb_lc_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_lc_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -2458,8 +2639,8 @@ subroutine psb_lc_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2479,7 +2660,7 @@ subroutine psb_lc_base_mv_to_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2491,17 +2672,17 @@ subroutine psb_lc_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2516,7 +2697,7 @@ subroutine psb_lc_base_mv_from_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2527,17 +2708,17 @@ subroutine psb_lc_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2552,7 +2733,7 @@ subroutine psb_lc_base_mv_to_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2564,7 +2745,7 @@ subroutine psb_lc_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_lc_coo_sparse_mat) @@ -2582,7 +2763,7 @@ subroutine psb_lc_base_mv_from_fmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2594,7 +2775,7 @@ subroutine psb_lc_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_lc_coo_sparse_mat) @@ -2610,23 +2791,23 @@ end subroutine psb_lc_base_mv_from_fmt subroutine psb_lc_base_clean_zeros(a, info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clean_zeros - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_lc_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_lc_base_clean_zeros -subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -2647,11 +2828,11 @@ subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_lc_base_csput_a -subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v use psb_c_base_vect_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2664,10 +2845,10 @@ subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() @@ -2677,11 +2858,11 @@ subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2693,7 +2874,7 @@ end subroutine psb_lc_base_csput_v subroutine psb_lc_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetrow @@ -2733,7 +2914,7 @@ end subroutine psb_lc_base_csgetrow ! subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetblk @@ -2757,22 +2938,22 @@ subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -2787,19 +2968,19 @@ subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'lc_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -2827,7 +3008,7 @@ end subroutine psb_lc_base_csgetblk subroutine psb_lc_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csclip @@ -2849,46 +3030,46 @@ subroutine psb_lc_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -2917,7 +3098,7 @@ end subroutine psb_lc_base_csclip ! subroutine psb_lc_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_tril @@ -2929,9 +3110,9 @@ subroutine psb_lc_base_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lc_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_lpk_), allocatable :: ia(:), ja(:) complex(psb_spk_), allocatable :: val(:) @@ -2943,51 +3124,51 @@ subroutine psb_lc_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -3019,7 +3200,7 @@ subroutine psb_lc_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -3027,8 +3208,8 @@ subroutine psb_lc_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -3041,7 +3222,7 @@ subroutine psb_lc_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -3050,8 +3231,8 @@ subroutine psb_lc_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -3069,7 +3250,7 @@ end subroutine psb_lc_base_tril subroutine psb_lc_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_triu @@ -3081,7 +3262,7 @@ subroutine psb_lc_base_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lc_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -3095,57 +3276,57 @@ subroutine psb_lc_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -3178,13 +3359,13 @@ subroutine psb_lc_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -3192,7 +3373,7 @@ subroutine psb_lc_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -3201,8 +3382,8 @@ subroutine psb_lc_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -3223,46 +3404,46 @@ end subroutine psb_lc_base_triu subroutine psb_lc_base_clone(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_lc_base_clone subroutine psb_lc_base_make_nonunit(a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a type(psb_lc_coo_sparse_mat) :: tmp - + integer(psb_ipk_) :: info integer(psb_lpk_) :: i, j, m, n, nz, mnm - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -3279,10 +3460,10 @@ subroutine psb_lc_base_make_nonunit(a) end subroutine psb_lc_base_make_nonunit -subroutine psb_lc_base_mold(a,b,info) +subroutine psb_lc_base_mold(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mold use psb_error_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3304,7 +3485,7 @@ end subroutine psb_lc_base_mold subroutine psb_lc_base_transp_2mat(a,b) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3324,11 +3505,11 @@ subroutine psb_lc_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3340,7 +3521,7 @@ end subroutine psb_lc_base_transp_2mat subroutine psb_lc_base_transc_2mat(a,b) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_2mat - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3360,11 +3541,11 @@ subroutine psb_lc_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3376,7 +3557,7 @@ end subroutine psb_lc_base_transc_2mat subroutine psb_lc_base_transp_1mat(a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a @@ -3390,12 +3571,12 @@ subroutine psb_lc_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3407,7 +3588,7 @@ end subroutine psb_lc_base_transp_1mat subroutine psb_lc_base_transc_1mat(a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_1mat - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a @@ -3421,12 +3602,12 @@ subroutine psb_lc_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3436,10 +3617,10 @@ subroutine psb_lc_base_transc_1mat(a) end subroutine psb_lc_base_transc_1mat -subroutine psb_lc_base_scals(d,a,info) +subroutine psb_lc_base_scals(d,a,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scals use psb_error_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3459,10 +3640,55 @@ subroutine psb_lc_base_scals(d,a,info) end subroutine psb_lc_base_scals -subroutine psb_lc_base_scal(d,a,info,side) +subroutine psb_lc_base_scalplusidentity(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_scalplusidentity + +subroutine psb_lc_base_scal(d,a,info,side) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scal use psb_error_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3488,7 +3714,7 @@ function psb_lc_base_maxval(a) result(res) use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_maxval - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3514,27 +3740,27 @@ function psb_lc_base_csnmi(a) result(res) use psb_realloc_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnmi - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3551,27 +3777,27 @@ function psb_lc_base_csnm1(a) result(res) use psb_realloc_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnm1 - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3582,7 +3808,7 @@ function psb_lc_base_csnm1(a) result(res) end function psb_lc_base_csnm1 -subroutine psb_lc_base_rowsum(d,a) +subroutine psb_lc_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_rowsum @@ -3604,7 +3830,7 @@ subroutine psb_lc_base_rowsum(d,a) end subroutine psb_lc_base_rowsum -subroutine psb_lc_base_arwsum(d,a) +subroutine psb_lc_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_arwsum @@ -3626,7 +3852,7 @@ subroutine psb_lc_base_arwsum(d,a) end subroutine psb_lc_base_arwsum -subroutine psb_lc_base_colsum(d,a) +subroutine psb_lc_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_colsum @@ -3648,7 +3874,7 @@ subroutine psb_lc_base_colsum(d,a) end subroutine psb_lc_base_colsum -subroutine psb_lc_base_aclsum(d,a) +subroutine psb_lc_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_aclsum @@ -3670,12 +3896,151 @@ subroutine psb_lc_base_aclsum(d,a) end subroutine psb_lc_base_aclsum -subroutine psb_lc_base_get_diag(a,d,info) +subroutine psb_lc_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_spaxpby + + complex(psb_spk_), intent(in) :: alpha + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: beta + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lc_base_spaxpby + +function psb_lc_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cmpval + + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lc_base_cmpval + +function psb_lc_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cmpmat + + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lc_base_cmpmat + +subroutine psb_lc_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_get_diag - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3701,7 +4066,7 @@ subroutine psb_lc_base_cp_to_icoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3710,22 +4075,22 @@ subroutine psb_lc_base_cp_to_icoo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. type(psb_lc_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3739,7 +4104,7 @@ subroutine psb_lc_base_cp_from_icoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3748,22 +4113,22 @@ subroutine psb_lc_base_cp_from_icoo(a,b,info) character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. type(psb_lc_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_icoo(b,info) + call tmp%cp_from_icoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3778,7 +4143,7 @@ subroutine psb_lc_base_cp_to_ifmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3788,10 +4153,10 @@ subroutine psb_lc_base_cp_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: icoo type(psb_lc_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3804,12 +4169,12 @@ subroutine psb_lc_base_cp_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3823,7 +4188,7 @@ subroutine psb_lc_base_cp_from_ifmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3835,10 +4200,10 @@ subroutine psb_lc_base_cp_from_ifmt(a,b,info) type(psb_lc_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_c_coo_sparse_mat) call a%cp_from_icoo(b,info) @@ -3848,8 +4213,8 @@ subroutine psb_lc_base_cp_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -3868,7 +4233,7 @@ subroutine psb_lc_base_mv_to_icoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3880,17 +4245,17 @@ subroutine psb_lc_base_mv_to_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -3905,7 +4270,7 @@ subroutine psb_lc_base_mv_from_icoo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3916,17 +4281,17 @@ subroutine psb_lc_base_mv_from_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -3942,7 +4307,7 @@ subroutine psb_lc_base_mv_to_ifmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3952,10 +4317,10 @@ subroutine psb_lc_base_mv_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: icoo type(psb_lc_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3968,12 +4333,12 @@ subroutine psb_lc_base_mv_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3987,7 +4352,7 @@ subroutine psb_lc_base_mv_from_ifmt(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lc_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3999,10 +4364,10 @@ subroutine psb_lc_base_mv_from_ifmt(a,b,info) type(psb_lc_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_c_coo_sparse_mat) call a%mv_from_icoo(b,info) @@ -4012,8 +4377,8 @@ subroutine psb_lc_base_mv_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -4026,5 +4391,3 @@ subroutine psb_lc_base_mv_from_ifmt(a,b,info) return end subroutine psb_lc_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_c_coo_impl.F90 b/base/serial/impl/psb_c_coo_impl.F90 index 347c87d97..88bdb66fe 100644 --- a/base/serial/impl/psb_c_coo_impl.F90 +++ b/base/serial/impl/psb_c_coo_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! -subroutine psb_c_coo_get_diag(a,d,info) +! +! +subroutine psb_c_coo_get_diag(a,d,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -47,19 +47,19 @@ subroutine psb_c_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = cone + if (a%is_unit()) then + d(1:mnm) = cone else d(1:mnm) = czero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -74,12 +74,12 @@ subroutine psb_c_coo_get_diag(a,d,info) end subroutine psb_c_coo_get_diag -subroutine psb_c_coo_scal(d,a,info,side) +subroutine psb_c_coo_scal(d,a,info,side) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -88,44 +88,44 @@ subroutine psb_c_coo_scal(d,a,info,side) integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -143,11 +143,11 @@ subroutine psb_c_coo_scal(d,a,info,side) end subroutine psb_c_coo_scal -subroutine psb_c_coo_scals(d,a,info) +subroutine psb_c_coo_scals(d,a,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -160,13 +160,14 @@ subroutine psb_c_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if do i=1,a%get_nzeros() a%val(i) = a%val(i) * d enddo + call a%set_host() call psb_erractionrestore(err_act) @@ -178,12 +179,207 @@ subroutine psb_c_coo_scals(d,a,info) end subroutine psb_c_coo_scals +subroutine psb_c_coo_scalplusidentity(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info -subroutine psb_c_coo_reallocate_nz(nz,a) + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + cone + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_coo_scalplusidentity + +subroutine psb_c_coo_spaxpby(alpha,a,beta,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_coo_spaxpby' + type(psb_c_coo_sparse_mat) :: tcoo,bcoo + integer(psb_ipk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_c_coo_spaxpby + +function psb_c_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cmpval + + class(psb_c_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_c_coo_cmpval + +function psb_c_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cmpmat + + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_ipk_) :: nza, nzb, nzl, M, N + type(psb_c_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-sone)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_c_coo_cmpmat + +subroutine psb_c_coo_reallocate_nz(nz,a) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -197,7 +393,7 @@ subroutine psb_c_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -211,11 +407,11 @@ subroutine psb_c_coo_reallocate_nz(nz,a) end subroutine psb_c_coo_reallocate_nz -subroutine psb_c_coo_ensure_size(nz,a) +subroutine psb_c_coo_ensure_size(nz,a) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -229,7 +425,7 @@ subroutine psb_c_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -243,10 +439,10 @@ subroutine psb_c_coo_ensure_size(nz,a) end subroutine psb_c_coo_ensure_size -subroutine psb_c_coo_mold(a,b,info) +subroutine psb_c_coo_mold(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mold use psb_error_mod - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -255,16 +451,16 @@ subroutine psb_c_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_c_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -279,9 +475,9 @@ end subroutine psb_c_coo_mold subroutine psb_c_coo_reinit(a,clear) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -293,17 +489,17 @@ subroutine psb_c_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = czero call a%set_host() call a%set_upd() @@ -328,7 +524,7 @@ subroutine psb_c_coo_trim(a) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' @@ -342,7 +538,7 @@ subroutine psb_c_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -355,13 +551,13 @@ end subroutine psb_c_coo_trim subroutine psb_c_coo_clean_zeros(a, info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_clean_zeros - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -372,14 +568,14 @@ subroutine psb_c_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_c_coo_clean_zeros subroutine psb_c_coo_clean_negidx(a,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_clean_negidx - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -387,13 +583,13 @@ subroutine psb_c_coo_clean_negidx(a,info) integer(psb_ipk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_c_coo_clean_negidx -subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_clean_negidx_inner - implicit none + implicit none integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) @@ -402,24 +598,24 @@ subroutine psb_c_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_ipk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_c_coo_clean_negidx_inner -subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -429,22 +625,22 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -452,7 +648,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(izero) @@ -464,7 +660,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -479,10 +675,10 @@ end subroutine psb_c_coo_allocate_mnnz subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -490,12 +686,12 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -504,26 +700,26 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -538,7 +734,7 @@ end subroutine psb_c_coo_print function psb_c_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_nz_row + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_nz_row implicit none class(psb_c_coo_sparse_mat), intent(in) :: a @@ -547,39 +743,39 @@ function psb_c_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -587,12 +783,12 @@ function psb_c_coo_get_nz_row(idx,a) result(res) end function psb_c_coo_get_nz_row -subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cssm - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -611,14 +807,14 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif if (a%is_dev()) call a%sync() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -643,7 +839,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() if (alpha == czero) then @@ -659,15 +855,15 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == czero) then + if (beta == czero) then call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & m,nc,nnz,a%ia,a%ja,a%val,& & x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -697,11 +893,11 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none + & ia,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) complex(psb_spk_), intent(in) :: val(*), x(ldx,*) @@ -719,7 +915,7 @@ contains end if - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if @@ -727,14 +923,14 @@ contains nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = czero - do + do if (j > nnz) exit if (ia(j) > i) exit acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) @@ -742,14 +938,14 @@ contains end do y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc(1:nc) = czero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j + 1 exit @@ -760,12 +956,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = czero - do + do i=nr, 1, -1 + acc(1:nc) = czero + do if (j < 1) exit if (ia(j) < i) exit acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) @@ -774,15 +970,15 @@ contains y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = czero - do + do i=nr, 1, -1 + acc(1:nc) = czero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j - 1 exit @@ -795,68 +991,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do @@ -864,68 +1060,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / conjg(val(j)) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / conjg(val(j)) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) j = j + 1 end do end do @@ -940,12 +1136,12 @@ end subroutine psb_c_coo_cssm -subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cssv - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -969,7 +1165,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -989,7 +1185,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1009,20 +1205,20 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) return end if - if (beta == czero) then + if (beta == czero) then call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if do i = 1, m y(i) = alpha*y(i) end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 @@ -1031,7 +1227,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -1047,11 +1243,11 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none + & ia,ja,val,x,y,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nz,ia(*),ja(*) complex(psb_spk_), intent(in) :: val(*), x(*) @@ -1062,21 +1258,21 @@ contains complex(psb_spk_) :: acc info = psb_success_ - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc = czero - do + do if (j > nnz) exit if (ia(j) > i) exit acc = acc + val(j)*y(ja(j)) @@ -1084,14 +1280,14 @@ contains end do y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc = czero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j + 1 exit @@ -1102,12 +1298,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc = czero - do + do i=nr, 1, -1 + acc = czero + do if (j < 1) exit if (ia(j) < i) exit acc = acc + val(j)*y(ja(j)) @@ -1116,15 +1312,15 @@ contains y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc = czero - do + do i=nr, 1, -1 + acc = czero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j - 1 exit @@ -1137,68 +1333,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 + y(jc) = y(jc) - val(j)*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do @@ -1206,68 +1402,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j - 1 + y(jc) = y(jc) - conjg(val(j))*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /conjg(val(j)) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc + y(jc) = y(jc) - conjg(val(j))*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc + y(jc) = y(jc) - conjg(val(j))*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /conjg(val(j)) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc + y(jc) = y(jc) - conjg(val(j))*acc j = j + 1 end do end do @@ -1281,12 +1477,12 @@ contains end subroutine psb_c_coo_cssv -subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csmv - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -1305,7 +1501,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1323,7 +1519,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1354,8 +1550,8 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == czero) then do i = 1, min(m,n) y(i) = alpha*x(i) @@ -1364,7 +1560,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) y(i) = czero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i) = beta*y(i) + alpha*x(i) end do do i = min(m,n)+1, m @@ -1386,28 +1582,28 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) end if - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = czero - do - if (i>nnz) then + do + if (i>nnz) then y(ir) = y(ir) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir) = y(ir) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = czero endif acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == cone) then i = 1 @@ -1425,7 +1621,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - a%val(i)*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1435,7 +1631,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) end if !.....end testing on alpha - else if (ctra) then + else if (ctra) then if (alpha == cone) then i = 1 @@ -1453,7 +1649,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - conjg(a%val(i))*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1475,12 +1671,12 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_c_coo_csmv -subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csmm - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1499,7 +1695,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1518,7 +1714,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1558,8 +1754,8 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == czero) then do i = 1, min(m,n) y(i,1:nc) = alpha*x(i,1:nc) @@ -1568,7 +1764,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) y(i,1:nc) = czero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) end do do i = min(m,n)+1, m @@ -1590,28 +1786,28 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) end if - if (.not.tra) then + if (.not.tra) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = czero - do - if (i>nnz) then + do + if (i>nnz) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = czero endif acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == cone) then i = 1 @@ -1629,7 +1825,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1657,7 +1853,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - conjg(a%val(i))*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1681,7 +1877,7 @@ end subroutine psb_c_coo_csmm function psb_c_coo_maxval(a) result(res) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_maxval - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1691,13 +1887,13 @@ function psb_c_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1707,7 +1903,7 @@ end function psb_c_coo_maxval function psb_c_coo_csnmi(a) result(res) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csnmi - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1724,15 +1920,15 @@ function psb_c_coo_csnmi(a) result(res) res = szero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = szero - do while (i<=nnz) + res = szero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -1747,7 +1943,7 @@ function psb_c_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = sone else vt = szero @@ -1759,7 +1955,7 @@ function psb_c_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_c_coo_csnmi @@ -1768,7 +1964,7 @@ function psb_c_coo_csnm1(a) result(res) use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csnm1 - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1787,7 +1983,7 @@ function psb_c_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = sone else vt = szero @@ -1803,7 +1999,7 @@ function psb_c_coo_csnm1(a) result(res) end function psb_c_coo_csnm1 -subroutine psb_c_coo_rowsum(d,a) +subroutine psb_c_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_rowsum @@ -1823,13 +2019,13 @@ subroutine psb_c_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = cone else d = czero @@ -1843,7 +2039,7 @@ subroutine psb_c_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1851,7 +2047,7 @@ subroutine psb_c_coo_rowsum(d,a) end subroutine psb_c_coo_rowsum -subroutine psb_c_coo_arwsum(d,a) +subroutine psb_c_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_arwsum @@ -1870,13 +2066,13 @@ subroutine psb_c_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1889,7 +2085,7 @@ subroutine psb_c_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1897,7 +2093,7 @@ subroutine psb_c_coo_arwsum(d,a) end subroutine psb_c_coo_arwsum -subroutine psb_c_coo_colsum(d,a) +subroutine psb_c_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_colsum @@ -1916,13 +2112,13 @@ subroutine psb_c_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = cone else d = czero @@ -1936,7 +2132,7 @@ subroutine psb_c_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1944,7 +2140,7 @@ subroutine psb_c_coo_colsum(d,a) end subroutine psb_c_coo_colsum -subroutine psb_c_coo_aclsum(d,a) +subroutine psb_c_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_aclsum @@ -1963,14 +2159,14 @@ subroutine psb_c_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1981,10 +2177,10 @@ subroutine psb_c_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -2009,7 +2205,7 @@ end subroutine psb_c_coo_aclsum subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2026,7 +2222,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2054,22 +2250,22 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2078,12 +2274,12 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2127,19 +2323,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2154,13 +2350,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2178,31 +2374,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -2211,7 +2407,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -2219,8 +2415,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -2233,12 +2429,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2250,11 +2446,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2268,7 +2464,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -2277,12 +2473,12 @@ end subroutine psb_c_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2327,27 +2523,27 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2356,12 +2552,12 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2409,19 +2605,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2436,13 +2632,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2460,34 +2656,34 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -2495,10 +2691,10 @@ contains end if enddo call psb_c_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -2507,7 +2703,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -2516,27 +2712,27 @@ contains nrd = max(a%get_nrows(),1) nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then - k = 0 + + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - end if + end if end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -2544,14 +2740,14 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) @@ -2573,12 +2769,12 @@ contains end subroutine psb_c_coo_csgetrow -subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csput_a - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -2590,30 +2786,30 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) character(len=20) :: name='c_coo_csput_a_impl' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -2624,13 +2820,13 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -2641,22 +2837,22 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call c_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2677,7 +2873,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: ia(:),ja(:) @@ -2688,11 +2884,11 @@ contains integer(psb_ipk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -2708,7 +2904,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2726,13 +2922,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2744,18 +2940,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2767,7 +2963,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2781,18 +2977,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2804,7 +3000,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2826,10 +3022,10 @@ contains end subroutine psb_c_coo_csput_a -subroutine psb_c_cp_coo_to_coo(a,b,info) +subroutine psb_c_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_coo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2868,10 +3064,10 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) end subroutine psb_c_cp_coo_to_coo -subroutine psb_c_cp_coo_from_coo(a,b,info) +subroutine psb_c_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_coo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2914,10 +3110,10 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) end subroutine psb_c_cp_coo_from_coo -subroutine psb_c_cp_coo_to_fmt(a,b,info) +subroutine psb_c_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_fmt - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2946,10 +3142,10 @@ subroutine psb_c_cp_coo_to_fmt(a,b,info) end subroutine psb_c_cp_coo_to_fmt -subroutine psb_c_cp_coo_from_fmt(a,b,info) +subroutine psb_c_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_fmt - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2980,10 +3176,10 @@ subroutine psb_c_cp_coo_from_fmt(a,b,info) end subroutine psb_c_cp_coo_from_fmt -subroutine psb_c_mv_coo_to_coo(a,b,info) +subroutine psb_c_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_to_coo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3022,10 +3218,10 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) end subroutine psb_c_mv_coo_to_coo -subroutine psb_c_mv_coo_from_coo(a,b,info) +subroutine psb_c_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_from_coo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3066,10 +3262,10 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) end subroutine psb_c_mv_coo_from_coo -subroutine psb_c_mv_coo_to_fmt(a,b,info) +subroutine psb_c_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_to_fmt - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3098,10 +3294,10 @@ subroutine psb_c_mv_coo_to_fmt(a,b,info) end subroutine psb_c_mv_coo_to_fmt -subroutine psb_c_mv_coo_from_fmt(a,b,info) +subroutine psb_c_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_mv_coo_from_fmt - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3134,7 +3330,7 @@ end subroutine psb_c_mv_coo_from_fmt subroutine psb_c_coo_cp_from(a,b) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_cp_from - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat), intent(in) :: b @@ -3164,7 +3360,7 @@ end subroutine psb_c_coo_cp_from subroutine psb_c_coo_mv_from(a,b) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mv_from - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat), intent(inout) :: b @@ -3193,11 +3389,11 @@ end subroutine psb_c_coo_mv_from -subroutine psb_c_fix_coo(a,info,idir) +subroutine psb_c_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3218,17 +3414,17 @@ subroutine psb_c_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_c_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -3251,14 +3447,14 @@ end subroutine psb_c_fix_coo -subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) @@ -3283,14 +3479,14 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -3299,17 +3495,17 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - select case(idir_) - case(psb_row_major_) + select case(idir_) + + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -3319,15 +3515,15 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -3338,9 +3534,9 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -3348,7 +3544,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3358,87 +3554,87 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3450,7 +3646,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -3459,7 +3655,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3469,73 +3665,73 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3544,15 +3740,15 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. - ! + ! let's try in place. + ! call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) @@ -3580,52 +3776,52 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3638,7 +3834,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -3648,13 +3844,13 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -3668,10 +3864,10 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -3679,7 +3875,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3689,86 +3885,86 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3780,7 +3976,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -3788,7 +3984,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3797,73 +3993,73 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3874,7 +4070,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & @@ -3902,42 +4098,42 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -3945,8 +4141,8 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3965,7 +4161,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -3979,10 +4175,10 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_c_fix_coo_inner -subroutine psb_c_cp_coo_to_lcoo(a,b,info) +subroutine psb_c_cp_coo_to_lcoo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_lcoo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4022,10 +4218,10 @@ subroutine psb_c_cp_coo_to_lcoo(a,b,info) end subroutine psb_c_cp_coo_to_lcoo -subroutine psb_c_cp_coo_from_lcoo(a,b,info) +subroutine psb_c_cp_coo_from_lcoo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_lcoo - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -4073,11 +4269,11 @@ end subroutine psb_c_cp_coo_from_lcoo ! ! -subroutine psb_lc_coo_get_diag(a,d,info) +subroutine psb_lc_coo_get_diag(a,d,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4092,19 +4288,19 @@ subroutine psb_lc_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = cone + if (a%is_unit()) then + d(1:mnm) = cone else d(1:mnm) = czero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -4118,12 +4314,12 @@ subroutine psb_lc_coo_get_diag(a,d,info) end subroutine psb_lc_coo_get_diag -subroutine psb_lc_coo_scal(d,a,info,side) +subroutine psb_lc_coo_scal(d,a,info,side) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4133,44 +4329,44 @@ subroutine psb_lc_coo_scal(d,a,info,side) integer(psb_lpk_) :: mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -4188,11 +4384,11 @@ subroutine psb_lc_coo_scal(d,a,info,side) end subroutine psb_lc_coo_scal -subroutine psb_lc_coo_scals(d,a,info) +subroutine psb_lc_coo_scals(d,a,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4206,7 +4402,7 @@ subroutine psb_lc_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -4228,7 +4424,7 @@ end subroutine psb_lc_coo_scals function psb_lc_coo_maxval(a) result(res) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_maxval - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -4238,13 +4434,13 @@ function psb_lc_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -4254,7 +4450,7 @@ end function psb_lc_coo_maxval function psb_lc_coo_csnmi(a) result(res) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnmi - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -4271,15 +4467,15 @@ function psb_lc_coo_csnmi(a) result(res) res = szero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = szero - do while (i<=nnz) + res = szero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -4294,7 +4490,7 @@ function psb_lc_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = sone else vt = szero @@ -4306,7 +4502,7 @@ function psb_lc_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_lc_coo_csnmi @@ -4315,7 +4511,7 @@ function psb_lc_coo_csnm1(a) result(res) use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnm1 - implicit none + implicit none class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -4334,7 +4530,7 @@ function psb_lc_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = sone else vt = szero @@ -4350,7 +4546,7 @@ function psb_lc_coo_csnm1(a) result(res) end function psb_lc_coo_csnm1 -subroutine psb_lc_coo_rowsum(d,a) +subroutine psb_lc_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_rowsum @@ -4371,13 +4567,13 @@ subroutine psb_lc_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = cone else d = czero @@ -4391,7 +4587,7 @@ subroutine psb_lc_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4399,7 +4595,7 @@ subroutine psb_lc_coo_rowsum(d,a) end subroutine psb_lc_coo_rowsum -subroutine psb_lc_coo_arwsum(d,a) +subroutine psb_lc_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_arwsum @@ -4419,13 +4615,13 @@ subroutine psb_lc_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -4438,7 +4634,7 @@ subroutine psb_lc_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4446,7 +4642,7 @@ subroutine psb_lc_coo_arwsum(d,a) end subroutine psb_lc_coo_arwsum -subroutine psb_lc_coo_colsum(d,a) +subroutine psb_lc_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_colsum @@ -4466,13 +4662,13 @@ subroutine psb_lc_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = cone else d = czero @@ -4486,7 +4682,7 @@ subroutine psb_lc_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4494,7 +4690,7 @@ subroutine psb_lc_coo_colsum(d,a) end subroutine psb_lc_coo_colsum -subroutine psb_lc_coo_aclsum(d,a) +subroutine psb_lc_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_aclsum @@ -4514,14 +4710,14 @@ subroutine psb_lc_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -4532,10 +4728,10 @@ subroutine psb_lc_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4543,11 +4739,207 @@ subroutine psb_lc_coo_aclsum(d,a) end subroutine psb_lc_coo_aclsum -subroutine psb_lc_coo_reallocate_nz(nz,a) +subroutine psb_lc_coo_scalplusidentity(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + cone + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_scalplusidentity + +subroutine psb_lc_coo_spaxpby(alpha,a,beta,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + complex(psb_spk_), intent(in) :: alpha + complex(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_spaxpby' + type(psb_lc_coo_sparse_mat) :: tcoo,bcoo + integer(psb_lpk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lc_coo_spaxpby + +function psb_lc_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cmpval + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lc_coo_cmpval + +function psb_lc_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cmpmat + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_lpk_) :: nza, nzb, nzl, M, N + type(psb_lc_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-1_psb_spk_)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lc_coo_cmpmat + +subroutine psb_lc_coo_reallocate_nz(nz,a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4562,7 +4954,7 @@ subroutine psb_lc_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4576,11 +4968,11 @@ subroutine psb_lc_coo_reallocate_nz(nz,a) end subroutine psb_lc_coo_reallocate_nz -subroutine psb_lc_coo_ensure_size(nz,a) +subroutine psb_lc_coo_ensure_size(nz,a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -4594,7 +4986,7 @@ subroutine psb_lc_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4608,10 +5000,10 @@ subroutine psb_lc_coo_ensure_size(nz,a) end subroutine psb_lc_coo_ensure_size -subroutine psb_lc_coo_mold(a,b,info) +subroutine psb_lc_coo_mold(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mold use psb_error_mod - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4620,16 +5012,16 @@ subroutine psb_lc_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_lc_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4644,9 +5036,9 @@ end subroutine psb_lc_coo_mold subroutine psb_lc_coo_reinit(a,clear) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4658,17 +5050,17 @@ subroutine psb_lc_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = czero call a%set_host() call a%set_upd() @@ -4693,7 +5085,7 @@ subroutine psb_lc_coo_trim(a) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info integer(psb_lpk_) :: nz @@ -4708,7 +5100,7 @@ subroutine psb_lc_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4721,13 +5113,13 @@ end subroutine psb_lc_coo_trim subroutine psb_lc_coo_clean_zeros(a, info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_zeros - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -4738,14 +5130,14 @@ subroutine psb_lc_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_lc_coo_clean_zeros subroutine psb_lc_coo_clean_negidx(a,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_negidx - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -4753,14 +5145,14 @@ subroutine psb_lc_coo_clean_negidx(a,info) integer(psb_lpk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_lc_coo_clean_negidx -#if defined(IPK4) && defined(LPK8) -subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +#if defined(IPK4) && defined(LPK8) +subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_negidx_inner - implicit none + implicit none integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) @@ -4769,25 +5161,25 @@ subroutine psb_lc_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_lpk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_lc_coo_clean_negidx_inner #endif -subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4798,22 +5190,22 @@ subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -4821,7 +5213,7 @@ subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(lzero) @@ -4833,7 +5225,7 @@ subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4848,10 +5240,10 @@ end subroutine psb_lc_coo_allocate_mnnz subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4864,8 +5256,8 @@ subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_lpk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4874,26 +5266,26 @@ subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -4908,7 +5300,7 @@ end subroutine psb_lc_coo_print function psb_lc_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_nz_row + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_nz_row implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a @@ -4918,40 +5310,40 @@ function psb_lc_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: inza if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. inza = nza ip = psb_bsrch(idx,inza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -4975,7 +5367,7 @@ end function psb_lc_coo_get_nz_row subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4992,7 +5384,7 @@ subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5021,22 +5413,22 @@ subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5045,12 +5437,12 @@ subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5095,19 +5487,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5122,13 +5514,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5146,31 +5538,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -5179,7 +5571,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -5187,8 +5579,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -5201,12 +5593,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5218,11 +5610,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5236,7 +5628,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -5245,12 +5637,12 @@ end subroutine psb_lc_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -5268,7 +5660,7 @@ subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5296,22 +5688,22 @@ subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5320,12 +5712,12 @@ subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5374,19 +5766,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5401,13 +5793,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5425,32 +5817,32 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -5458,10 +5850,10 @@ contains end if enddo call psb_lc_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -5470,7 +5862,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -5484,12 +5876,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5503,11 +5895,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5531,12 +5923,12 @@ contains end subroutine psb_lc_coo_csgetrow -subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csput_a - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -5549,30 +5941,30 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) logical, parameter :: debug=.false. integer(psb_lpk_) :: nza, i,j,k, nzl, isza integer(psb_ipk_) :: debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -5583,13 +5975,13 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -5600,22 +5992,22 @@ subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call lc_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -5636,7 +6028,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: ia(:),ja(:) @@ -5647,11 +6039,11 @@ contains integer(psb_lpk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -5667,7 +6059,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -5685,13 +6077,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() innz = nnz @@ -5702,18 +6094,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5725,7 +6117,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -5739,18 +6131,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5762,7 +6154,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -5784,10 +6176,10 @@ contains end subroutine psb_lc_coo_csput_a -subroutine psb_lc_cp_coo_to_coo(a,b,info) +subroutine psb_lc_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_coo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5827,10 +6219,10 @@ subroutine psb_lc_cp_coo_to_coo(a,b,info) end subroutine psb_lc_cp_coo_to_coo -subroutine psb_lc_cp_coo_from_coo(a,b,info) +subroutine psb_lc_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_coo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5873,10 +6265,10 @@ subroutine psb_lc_cp_coo_from_coo(a,b,info) end subroutine psb_lc_cp_coo_from_coo -subroutine psb_lc_cp_coo_to_fmt(a,b,info) +subroutine psb_lc_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_fmt - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5905,10 +6297,10 @@ subroutine psb_lc_cp_coo_to_fmt(a,b,info) end subroutine psb_lc_cp_coo_to_fmt -subroutine psb_lc_cp_coo_from_fmt(a,b,info) +subroutine psb_lc_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_fmt - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5939,10 +6331,10 @@ subroutine psb_lc_cp_coo_from_fmt(a,b,info) end subroutine psb_lc_cp_coo_from_fmt -subroutine psb_lc_mv_coo_to_coo(a,b,info) +subroutine psb_lc_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_coo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5981,10 +6373,10 @@ subroutine psb_lc_mv_coo_to_coo(a,b,info) end subroutine psb_lc_mv_coo_to_coo -subroutine psb_lc_mv_coo_from_coo(a,b,info) +subroutine psb_lc_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_coo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6025,10 +6417,10 @@ subroutine psb_lc_mv_coo_from_coo(a,b,info) end subroutine psb_lc_mv_coo_from_coo -subroutine psb_lc_mv_coo_to_fmt(a,b,info) +subroutine psb_lc_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_fmt - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6057,10 +6449,10 @@ subroutine psb_lc_mv_coo_to_fmt(a,b,info) end subroutine psb_lc_mv_coo_to_fmt -subroutine psb_lc_mv_coo_from_fmt(a,b,info) +subroutine psb_lc_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_fmt - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6093,7 +6485,7 @@ end subroutine psb_lc_mv_coo_from_fmt subroutine psb_lc_coo_cp_from(a,b) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cp_from - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a type(psb_lc_coo_sparse_mat), intent(in) :: b @@ -6123,7 +6515,7 @@ end subroutine psb_lc_coo_cp_from subroutine psb_lc_coo_mv_from(a,b) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mv_from - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a type(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -6152,11 +6544,11 @@ end subroutine psb_lc_coo_mv_from -subroutine psb_lc_fix_coo(a,info,idir) +subroutine psb_lc_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -6177,17 +6569,17 @@ subroutine psb_lc_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_lc_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -6210,14 +6602,14 @@ end subroutine psb_lc_fix_coo -subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -6244,14 +6636,14 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -6260,16 +6652,16 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - select case(idir_) + select case(idir_) - case(psb_row_major_) + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -6277,17 +6669,17 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = (info == 0) else use_buffers = .false. - end if - - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + end if + + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -6298,9 +6690,9 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -6308,7 +6700,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6318,87 +6710,87 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6410,7 +6802,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -6419,7 +6811,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6429,73 +6821,73 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6504,14 +6896,14 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. + ! let's try in place. ! inzin = nzin call psi_msort_up(inzin,ia(1:),iaux(1:),iret) @@ -6541,52 +6933,52 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6599,7 +6991,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -6609,13 +7001,13 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -6629,10 +7021,10 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -6640,7 +7032,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6650,86 +7042,86 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6741,7 +7133,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -6749,7 +7141,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6758,73 +7150,73 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6835,7 +7227,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then inzin = nzin call psi_msort_up(inzin,ja(1:),iaux(1:),iret) @@ -6864,42 +7256,42 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -6907,8 +7299,8 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6927,7 +7319,7 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -6941,10 +7333,10 @@ subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_lc_fix_coo_inner -subroutine psb_lc_cp_coo_to_icoo(a,b,info) +subroutine psb_lc_cp_coo_to_icoo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_icoo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6984,10 +7376,10 @@ subroutine psb_lc_cp_coo_to_icoo(a,b,info) end subroutine psb_lc_cp_coo_to_icoo -subroutine psb_lc_cp_coo_from_icoo(a,b,info) +subroutine psb_lc_cp_coo_from_icoo(a,b,info) use psb_error_mod use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_icoo - implicit none + implicit none class(psb_lc_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -7027,4 +7419,3 @@ subroutine psb_lc_cp_coo_from_icoo(a,b,info) return end subroutine psb_lc_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index d04d5fbf8..4769f5ff4 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csmv - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -72,7 +72,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -81,7 +81,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) if (a%is_dev()) call a%sync() - if (size(x,1) psb_c_csc_csmm - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -350,13 +350,13 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) end if tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -364,16 +364,16 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_c_csc_cssv - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -632,7 +632,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -642,28 +642,28 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x,1) psb_c_csc_cssm - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -852,7 +852,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -862,23 +862,23 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (size(x,1) psb_c_csc_maxval - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1066,7 +1066,7 @@ function psb_c_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero @@ -1074,7 +1074,7 @@ function psb_c_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1085,7 +1085,7 @@ function psb_c_csc_csnm1(a) result(res) use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csnm1 - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1099,13 +1099,13 @@ function psb_c_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = szero + res = szero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -1115,12 +1115,12 @@ function psb_c_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_c_csc_csnm1 -subroutine psb_c_csc_colsum(d,a) +subroutine psb_c_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_colsum @@ -1140,7 +1140,7 @@ subroutine psb_c_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1148,19 +1148,19 @@ subroutine psb_c_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = cone else d(i) = czero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1168,7 +1168,7 @@ subroutine psb_c_csc_colsum(d,a) end subroutine psb_c_csc_colsum -subroutine psb_c_csc_aclsum(d,a) +subroutine psb_c_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_aclsum @@ -1188,7 +1188,7 @@ subroutine psb_c_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1197,25 +1197,25 @@ subroutine psb_c_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = sone else d(i) = szero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1223,7 +1223,7 @@ subroutine psb_c_csc_aclsum(d,a) end subroutine psb_c_csc_aclsum -subroutine psb_c_csc_rowsum(d,a) +subroutine psb_c_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_rowsum @@ -1244,14 +1244,14 @@ subroutine psb_c_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = cone else d = czero @@ -1265,7 +1265,7 @@ subroutine psb_c_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1273,7 +1273,7 @@ subroutine psb_c_csc_rowsum(d,a) end subroutine psb_c_csc_rowsum -subroutine psb_c_csc_arwsum(d,a) +subroutine psb_c_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_arwsum @@ -1294,14 +1294,14 @@ subroutine psb_c_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1315,7 +1315,7 @@ subroutine psb_c_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1324,11 +1324,11 @@ subroutine psb_c_csc_arwsum(d,a) end subroutine psb_c_csc_arwsum -subroutine psb_c_csc_get_diag(a,d,info) +subroutine psb_c_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_get_diag - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1343,28 +1343,28 @@ subroutine psb_c_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = cone + if (a%is_unit()) then + d(1:mnm) = cone else do i=1, mnm d(i) = czero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = czero end do call psb_erractionrestore(err_act) @@ -1377,12 +1377,12 @@ subroutine psb_c_csc_get_diag(a,d,info) end subroutine psb_c_csc_get_diag -subroutine psb_c_csc_scal(d,a,info,side) +subroutine psb_c_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scal use psb_string_mod - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1393,7 +1393,7 @@ subroutine psb_c_csc_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -1401,39 +1401,39 @@ subroutine psb_c_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -1449,11 +1449,11 @@ subroutine psb_c_csc_scal(d,a,info,side) end subroutine psb_c_csc_scal -subroutine psb_c_csc_scals(d,a,info) +subroutine psb_c_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_scals - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1467,7 +1467,7 @@ subroutine psb_c_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1486,7 +1486,7 @@ subroutine psb_c_csc_scals(d,a,info) end subroutine psb_c_csc_scals -! == =================================== +! == =================================== ! ! ! @@ -1496,11 +1496,11 @@ end subroutine psb_c_csc_scals ! ! ! -! == =================================== +! == =================================== subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1518,7 +1518,7 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1547,35 +1547,35 @@ subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1621,12 +1621,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1637,19 +1637,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1663,9 +1663,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1677,9 +1677,9 @@ contains enddo end do end if - + end subroutine csc_getptn - + end subroutine psb_c_csc_csgetptn @@ -1687,7 +1687,7 @@ end subroutine psb_c_csc_csgetptn subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1706,7 +1706,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1716,7 +1716,7 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1736,22 +1736,22 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -1759,13 +1759,13 @@ subroutine psb_c_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1813,12 +1813,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1829,7 +1829,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -1837,12 +1837,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1858,9 +1858,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1880,11 +1880,11 @@ end subroutine psb_c_csc_csgetrow -subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput_a - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -1903,26 +1903,26 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -1933,25 +1933,25 @@ subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_c_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -1977,7 +1977,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -1995,13 +1995,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -2011,19 +2011,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2036,18 +2036,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2070,12 +2070,12 @@ end subroutine psb_c_csc_csput_a -subroutine psb_c_cp_csc_from_coo(a,b,info) +subroutine psb_c_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_from_coo - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b @@ -2098,11 +2098,11 @@ end subroutine psb_c_cp_csc_from_coo -subroutine psb_c_cp_csc_to_coo(a,b,info) +subroutine psb_c_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_to_coo - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b @@ -2132,7 +2132,7 @@ subroutine psb_c_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -2140,12 +2140,12 @@ subroutine psb_c_cp_csc_to_coo(a,b,info) end subroutine psb_c_cp_csc_to_coo -subroutine psb_c_mv_csc_to_coo(a,b,info) +subroutine psb_c_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_to_coo - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b @@ -2183,13 +2183,13 @@ end subroutine psb_c_mv_csc_to_coo -subroutine psb_c_mv_csc_from_coo(a,b,info) +subroutine psb_c_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_coo - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b @@ -2213,7 +2213,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -2236,17 +2236,17 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_c_mv_csc_from_coo -subroutine psb_c_mv_csc_to_fmt(a,b,info) +subroutine psb_c_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_to_fmt - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b @@ -2262,10 +2262,10 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_c_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_c_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -2282,12 +2282,12 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info) end subroutine psb_c_mv_csc_to_fmt !!$ -subroutine psb_c_cp_csc_to_fmt(a,b,info) +subroutine psb_c_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_to_fmt - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b @@ -2303,10 +2303,10 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_c_csc_sparse_mat) + type is (psb_c_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat nc = a%get_ncols() @@ -2324,12 +2324,12 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info) end subroutine psb_c_cp_csc_to_fmt -subroutine psb_c_mv_csc_from_fmt(a,b,info) +subroutine psb_c_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_mv_csc_from_fmt - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b @@ -2345,10 +2345,10 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_c_csc_sparse_mat) + type is (psb_c_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat @@ -2369,19 +2369,19 @@ end subroutine psb_c_mv_csc_from_fmt subroutine psb_c_csc_clean_zeros(a, info) use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_clean_zeros - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nc - integer(psb_ipk_), allocatable :: ilcp(:) - + integer(psb_ipk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= czero) then @@ -2396,12 +2396,12 @@ subroutine psb_c_csc_clean_zeros(a, info) call a%set_host() end subroutine psb_c_csc_clean_zeros -subroutine psb_c_cp_csc_from_fmt(a,b,info) +subroutine psb_c_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_cp_csc_from_fmt - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b @@ -2417,10 +2417,10 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_c_csc_sparse_mat) + type is (psb_c_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat nc = b%get_ncols() @@ -2435,14 +2435,14 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_c_cp_csc_from_fmt -subroutine psb_c_csc_mold(a,b,info) +subroutine psb_c_csc_mold(a,b,info) use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mold use psb_error_mod - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2452,16 +2452,16 @@ subroutine psb_c_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_c_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -2473,11 +2473,11 @@ subroutine psb_c_csc_mold(a,b,info) end subroutine psb_c_csc_mold -subroutine psb_c_csc_reallocate_nz(nz,a) +subroutine psb_c_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -2490,7 +2490,7 @@ subroutine psb_c_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -2508,7 +2508,7 @@ end subroutine psb_c_csc_reallocate_nz !!$subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& !!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ ! Output is always in COO format +!!$ ! Output is always in COO format !!$ use psb_error_mod !!$ use psb_const_mod !!$ use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csgetblk @@ -2531,12 +2531,12 @@ end subroutine psb_c_csc_reallocate_nz !!$ call psb_erractionsave(err_act) !!$ info = psb_success_ !!$ -!!$ if (present(append)) then +!!$ if (present(append)) then !!$ append_ = append !!$ else !!$ append_ = .false. !!$ endif -!!$ if (append_) then +!!$ if (append_) then !!$ nzin = a%get_nzeros() !!$ else !!$ nzin = 0 @@ -2564,9 +2564,9 @@ end subroutine psb_c_csc_reallocate_nz subroutine psb_c_csc_reinit(a,clear) use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_reinit - implicit none + implicit none - class(psb_c_csc_sparse_mat), intent(inout) :: a + class(psb_c_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2580,16 +2580,16 @@ subroutine psb_c_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = czero call a%set_upd() call a%set_host() @@ -2612,7 +2612,7 @@ subroutine psb_c_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_trim - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, n integer(psb_ipk_) :: ierr(5) @@ -2627,7 +2627,7 @@ subroutine psb_c_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2637,11 +2637,11 @@ subroutine psb_c_csc_trim(a) end subroutine psb_c_csc_trim -subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -2652,26 +2652,26 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -2679,7 +2679,7 @@ subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -2702,25 +2702,27 @@ end subroutine psb_c_csc_allocate_mnnz subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_csc_print' logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='complex' character(len=80) :: frmt - integer(psb_ipk_) :: i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + - write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2729,35 +2731,35 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -2770,7 +2772,7 @@ subroutine psb_ccscspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_ccscspspmm - implicit none + implicit none class(psb_c_csc_sparse_mat), intent(in) :: a,b type(psb_c_csc_sparse_mat), intent(out) :: c @@ -2790,7 +2792,7 @@ subroutine psb_ccscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -2819,9 +2821,9 @@ subroutine psb_ccscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_c_csc_sparse_mat), intent(in) :: a,b type(psb_c_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -2844,29 +2846,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -2874,11 +2876,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do @@ -2891,11 +2893,11 @@ end subroutine psb_ccscspspmm -subroutine psb_lc_csc_get_diag(a,d,info) +subroutine psb_lc_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_get_diag - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2910,28 +2912,28 @@ subroutine psb_lc_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = cone + if (a%is_unit()) then + d(1:mnm) = cone else do i=1, mnm d(i) = czero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = czero end do call psb_erractionrestore(err_act) @@ -2944,12 +2946,12 @@ subroutine psb_lc_csc_get_diag(a,d,info) end subroutine psb_lc_csc_get_diag -subroutine psb_lc_csc_scal(d,a,info,side) +subroutine psb_lc_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_scal use psb_string_mod - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2960,7 +2962,7 @@ subroutine psb_lc_csc_scal(d,a,info,side) integer(psb_ipk_) :: err_act,ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -2968,39 +2970,39 @@ subroutine psb_lc_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -3016,11 +3018,11 @@ subroutine psb_lc_csc_scal(d,a,info,side) end subroutine psb_lc_csc_scal -subroutine psb_lc_csc_scals(d,a,info) +subroutine psb_lc_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_scals - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3034,7 +3036,7 @@ subroutine psb_lc_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3056,7 +3058,7 @@ end subroutine psb_lc_csc_scals function psb_lc_csc_maxval(a) result(res) use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_maxval - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3065,7 +3067,7 @@ function psb_lc_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero @@ -3073,7 +3075,7 @@ function psb_lc_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3084,7 +3086,7 @@ function psb_lc_csc_csnm1(a) result(res) use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csnm1 - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3097,13 +3099,13 @@ function psb_lc_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = szero + res = szero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -3113,12 +3115,12 @@ function psb_lc_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_lc_csc_csnm1 -subroutine psb_lc_csc_colsum(d,a) +subroutine psb_lc_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_colsum @@ -3139,7 +3141,7 @@ subroutine psb_lc_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3147,19 +3149,19 @@ subroutine psb_lc_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = cone else d(i) = czero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3167,7 +3169,7 @@ subroutine psb_lc_csc_colsum(d,a) end subroutine psb_lc_csc_colsum -subroutine psb_lc_csc_aclsum(d,a) +subroutine psb_lc_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_aclsum @@ -3188,7 +3190,7 @@ subroutine psb_lc_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3197,25 +3199,25 @@ subroutine psb_lc_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = sone else d(i) = szero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3223,7 +3225,7 @@ subroutine psb_lc_csc_aclsum(d,a) end subroutine psb_lc_csc_aclsum -subroutine psb_lc_csc_rowsum(d,a) +subroutine psb_lc_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_rowsum @@ -3231,7 +3233,7 @@ subroutine psb_lc_csc_rowsum(d,a) complex(psb_spk_), intent(out) :: d(:) integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc - integer(psb_epk_) :: m,n + integer(psb_epk_) :: m,n complex(psb_spk_) :: acc complex(psb_spk_), allocatable :: vt(:) logical :: tra @@ -3245,14 +3247,14 @@ subroutine psb_lc_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = cone else d = czero @@ -3266,7 +3268,7 @@ subroutine psb_lc_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3274,7 +3276,7 @@ subroutine psb_lc_csc_rowsum(d,a) end subroutine psb_lc_csc_rowsum -subroutine psb_lc_csc_arwsum(d,a) +subroutine psb_lc_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_arwsum @@ -3296,14 +3298,14 @@ subroutine psb_lc_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -3317,7 +3319,7 @@ subroutine psb_lc_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3326,7 +3328,7 @@ subroutine psb_lc_csc_arwsum(d,a) end subroutine psb_lc_csc_arwsum -! == =================================== +! == =================================== ! ! ! @@ -3336,11 +3338,11 @@ end subroutine psb_lc_csc_arwsum ! ! ! -! == =================================== +! == =================================== subroutine psb_lc_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3358,7 +3360,7 @@ subroutine psb_lc_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3387,35 +3389,35 @@ subroutine psb_lc_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call lcsc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3461,12 +3463,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3477,19 +3479,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3503,9 +3505,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3517,9 +3519,9 @@ contains enddo end do end if - + end subroutine lcsc_getptn - + end subroutine psb_lc_csc_csgetptn @@ -3527,7 +3529,7 @@ end subroutine psb_lc_csc_csgetptn subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3546,7 +3548,7 @@ subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3556,7 +3558,7 @@ subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -3576,22 +3578,22 @@ subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -3599,13 +3601,13 @@ subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call lcsc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3653,12 +3655,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3669,7 +3671,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -3677,12 +3679,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3698,9 +3700,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3720,11 +3722,11 @@ end subroutine psb_lc_csc_csgetrow -subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csput_a - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -3743,26 +3745,26 @@ subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -3773,25 +3775,25 @@ subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_lc_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -3817,7 +3819,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -3835,13 +3837,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -3851,19 +3853,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -3876,18 +3878,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -3909,12 +3911,12 @@ contains end subroutine psb_lc_csc_csput_a -subroutine psb_lc_cp_csc_from_coo(a,b,info) +subroutine psb_lc_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_from_coo - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b @@ -3937,11 +3939,11 @@ end subroutine psb_lc_cp_csc_from_coo -subroutine psb_lc_cp_csc_to_coo(a,b,info) +subroutine psb_lc_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_to_coo - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -3971,7 +3973,7 @@ subroutine psb_lc_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -3979,12 +3981,12 @@ subroutine psb_lc_cp_csc_to_coo(a,b,info) end subroutine psb_lc_cp_csc_to_coo -subroutine psb_lc_mv_csc_to_coo(a,b,info) +subroutine psb_lc_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_to_coo - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -4021,13 +4023,13 @@ subroutine psb_lc_mv_csc_to_coo(a,b,info) end subroutine psb_lc_mv_csc_to_coo -subroutine psb_lc_mv_csc_from_coo(a,b,info) +subroutine psb_lc_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_from_coo - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -4051,7 +4053,7 @@ subroutine psb_lc_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -4074,17 +4076,17 @@ subroutine psb_lc_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_lc_mv_csc_from_coo -subroutine psb_lc_mv_csc_to_fmt(a,b,info) +subroutine psb_lc_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_to_fmt - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b @@ -4100,10 +4102,10 @@ subroutine psb_lc_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_lc_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_lc_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -4120,12 +4122,12 @@ subroutine psb_lc_mv_csc_to_fmt(a,b,info) end subroutine psb_lc_mv_csc_to_fmt !!$ -subroutine psb_lc_cp_csc_to_fmt(a,b,info) +subroutine psb_lc_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_to_fmt - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b @@ -4141,10 +4143,10 @@ subroutine psb_lc_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_lc_csc_sparse_mat) + type is (psb_lc_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat nc = a%get_ncols() @@ -4162,12 +4164,12 @@ subroutine psb_lc_cp_csc_to_fmt(a,b,info) end subroutine psb_lc_cp_csc_to_fmt -subroutine psb_lc_mv_csc_from_fmt(a,b,info) +subroutine psb_lc_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_from_fmt - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b @@ -4183,10 +4185,10 @@ subroutine psb_lc_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_lc_csc_sparse_mat) + type is (psb_lc_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat @@ -4206,12 +4208,12 @@ end subroutine psb_lc_mv_csc_from_fmt -subroutine psb_lc_cp_csc_from_fmt(a,b,info) +subroutine psb_lc_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_from_fmt - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b @@ -4227,10 +4229,10 @@ subroutine psb_lc_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_lc_csc_sparse_mat) + type is (psb_lc_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat nc = b%get_ncols() @@ -4245,25 +4247,25 @@ subroutine psb_lc_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_lc_cp_csc_from_fmt subroutine psb_lc_csc_clean_zeros(a, info) use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_clean_zeros - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nc - integer(psb_lpk_), allocatable :: ilcp(:) - + integer(psb_lpk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= czero) then @@ -4279,10 +4281,10 @@ subroutine psb_lc_csc_clean_zeros(a, info) end subroutine psb_lc_csc_clean_zeros -subroutine psb_lc_csc_mold(a,b,info) +subroutine psb_lc_csc_mold(a,b,info) use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_mold use psb_error_mod - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4291,16 +4293,16 @@ subroutine psb_lc_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_lc_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4312,11 +4314,11 @@ subroutine psb_lc_csc_mold(a,b,info) end subroutine psb_lc_csc_mold -subroutine psb_lc_csc_reallocate_nz(nz,a) +subroutine psb_lc_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4328,7 +4330,7 @@ subroutine psb_lc_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4346,7 +4348,7 @@ end subroutine psb_lc_csc_reallocate_nz subroutine psb_lc_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csgetblk @@ -4369,12 +4371,12 @@ subroutine psb_lc_csc_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 @@ -4402,9 +4404,9 @@ end subroutine psb_lc_csc_csgetblk subroutine psb_lc_csc_reinit(a,clear) use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_reinit - implicit none + implicit none - class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4418,16 +4420,16 @@ subroutine psb_lc_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = czero call a%set_upd() call a%set_host() @@ -4450,7 +4452,7 @@ subroutine psb_lc_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_trim - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, n integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4465,7 +4467,7 @@ subroutine psb_lc_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4475,11 +4477,11 @@ subroutine psb_lc_csc_trim(a) end subroutine psb_lc_csc_trim -subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_lc_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4490,26 +4492,26 @@ subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -4517,7 +4519,7 @@ subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -4540,24 +4542,25 @@ end subroutine psb_lc_csc_allocate_mnnz subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='lc_csc_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4566,36 +4569,36 @@ subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -4608,7 +4611,7 @@ subroutine psb_lccscspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_lccscspspmm - implicit none + implicit none class(psb_lc_csc_sparse_mat), intent(in) :: a,b type(psb_lc_csc_sparse_mat), intent(out) :: c @@ -4628,7 +4631,7 @@ subroutine psb_lccscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -4657,9 +4660,9 @@ subroutine psb_lccscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_lc_csc_sparse_mat), intent(in) :: a,b type(psb_lc_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -4682,29 +4685,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -4712,11 +4715,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index 15f52a37e..7b2f61a2a 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csmv - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -73,7 +73,7 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -83,7 +83,7 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_c_csr_csmm - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -418,7 +418,7 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -426,7 +426,7 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -434,16 +434,16 @@ subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_c_csr_cssv - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -766,7 +766,7 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -776,26 +776,26 @@ subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x) psb_c_csr_cssm - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1030,7 +1030,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1041,9 +1041,9 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1063,14 +1063,14 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == czero) then + if (beta == czero) then call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -1078,7 +1078,7 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) end if call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) end do @@ -1099,11 +1099,11 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,& - & irp,ja,val,x,ldx,y,ldy,info) - implicit none + & irp,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit integer(psb_ipk_), intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) complex(psb_spk_), intent(in) :: val(*), x(ldx,*) @@ -1120,38 +1120,38 @@ contains end if - if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then do i=1, nr - acc = czero + acc = czero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr - acc = czero + acc = czero do j=irp(i), irp(i+1)-2 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then - do i=nr, 1, -1 - acc = czero + if (unit) then + do i=nr, 1, -1 + acc = czero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then - do i=nr, 1, -1 - acc = czero + else if (.not.unit) then + do i=nr, 1, -1 + acc = czero do j=irp(i)+1, irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -1161,96 +1161,96 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/val(irp(i)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i+1)-1)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i))) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do end if @@ -1264,7 +1264,7 @@ end subroutine psb_c_csr_cssm function psb_c_csr_maxval(a) result(res) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_maxval - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1277,7 +1277,7 @@ function psb_c_csr_maxval(a) result(res) res = szero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1286,7 +1286,7 @@ end function psb_c_csr_maxval function psb_c_csr_csnmi(a) result(res) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csnmi - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1303,7 +1303,7 @@ function psb_c_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -1311,7 +1311,7 @@ function psb_c_csr_csnmi(a) result(res) end function psb_c_csr_csnmi -subroutine psb_c_csr_rowsum(d,a) +subroutine psb_c_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_rowsum @@ -1331,7 +1331,7 @@ subroutine psb_c_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1340,12 +1340,12 @@ subroutine psb_c_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = czero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + cone end do @@ -1353,7 +1353,7 @@ subroutine psb_c_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1361,7 +1361,7 @@ subroutine psb_c_csr_rowsum(d,a) end subroutine psb_c_csr_rowsum -subroutine psb_c_csr_arwsum(d,a) +subroutine psb_c_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_arwsum @@ -1381,7 +1381,7 @@ subroutine psb_c_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1391,19 +1391,19 @@ subroutine psb_c_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1411,7 +1411,7 @@ subroutine psb_c_csr_arwsum(d,a) end subroutine psb_c_csr_arwsum -subroutine psb_c_csr_colsum(d,a) +subroutine psb_c_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_colsum @@ -1432,7 +1432,7 @@ subroutine psb_c_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1447,8 +1447,8 @@ subroutine psb_c_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + cone end do @@ -1456,7 +1456,7 @@ subroutine psb_c_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1464,7 +1464,7 @@ subroutine psb_c_csr_colsum(d,a) end subroutine psb_c_csr_colsum -subroutine psb_c_csr_aclsum(d,a) +subroutine psb_c_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_aclsum @@ -1485,7 +1485,7 @@ subroutine psb_c_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1500,8 +1500,8 @@ subroutine psb_c_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + sone end do @@ -1509,7 +1509,7 @@ subroutine psb_c_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1517,11 +1517,11 @@ subroutine psb_c_csr_aclsum(d,a) end subroutine psb_c_csr_aclsum -subroutine psb_c_csr_get_diag(a,d,info) +subroutine psb_c_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_get_diag - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1536,28 +1536,28 @@ subroutine psb_c_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = cone else do i=1, mnm d(i) = czero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = czero end do @@ -1570,12 +1570,12 @@ subroutine psb_c_csr_get_diag(a,d,info) end subroutine psb_c_csr_get_diag -subroutine psb_c_csr_scal(d,a,info,side) +subroutine psb_c_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scal use psb_string_mod - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1585,47 +1585,47 @@ subroutine psb_c_csr_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -1643,11 +1643,11 @@ subroutine psb_c_csr_scal(d,a,info,side) end subroutine psb_c_csr_scal -subroutine psb_c_csr_scals(d,a,info) +subroutine psb_c_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_scals - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1660,7 +1660,7 @@ subroutine psb_c_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1680,7 +1680,7 @@ end subroutine psb_c_csr_scals -! == =================================== +! == =================================== ! ! ! @@ -1690,14 +1690,14 @@ end subroutine psb_c_csr_scals ! ! ! -! == =================================== +! == =================================== -subroutine psb_c_csr_reallocate_nz(nz,a) +subroutine psb_c_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1709,7 +1709,7 @@ subroutine psb_c_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -1723,10 +1723,10 @@ subroutine psb_c_csr_reallocate_nz(nz,a) end subroutine psb_c_csr_reallocate_nz -subroutine psb_c_csr_mold(a,b,info) +subroutine psb_c_csr_mold(a,b,info) use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mold use psb_error_mod - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1735,16 +1735,16 @@ subroutine psb_c_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_c_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -1755,11 +1755,11 @@ subroutine psb_c_csr_mold(a,b,info) end subroutine psb_c_csr_mold -subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1770,26 +1770,26 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -1797,7 +1797,7 @@ subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1820,7 +1820,7 @@ end subroutine psb_c_csr_allocate_mnnz subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1838,7 +1838,7 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -1866,35 +1866,35 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1940,32 +1940,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -1976,7 +1976,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -1987,13 +1987,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_c_csr_csgetptn subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2021,7 +2021,7 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -2040,27 +2040,27 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2068,13 +2068,13 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2121,12 +2121,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -2134,23 +2134,23 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - + if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2162,7 +2162,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2183,7 +2183,7 @@ end subroutine psb_c_csr_csgetrow ! subroutine psb_c_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_tril @@ -2195,7 +2195,7 @@ subroutine psb_c_csr_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_c_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2206,57 +2206,57 @@ subroutine psb_c_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -2265,7 +2265,7 @@ subroutine psb_c_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -2281,7 +2281,7 @@ subroutine psb_c_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -2289,17 +2289,17 @@ subroutine psb_c_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -2318,8 +2318,8 @@ subroutine psb_c_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -2337,7 +2337,7 @@ end subroutine psb_c_csr_tril subroutine psb_c_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_triu @@ -2349,7 +2349,7 @@ subroutine psb_c_csr_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_c_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2360,57 +2360,57 @@ subroutine psb_c_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -2419,7 +2419,7 @@ subroutine psb_c_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -2471,8 +2471,8 @@ subroutine psb_c_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -2489,11 +2489,11 @@ subroutine psb_c_csr_triu(a,u,info,& end subroutine psb_c_csr_triu -subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput_a - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -2511,23 +2511,23 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_; i=1 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_; i=2 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_; i=3 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_; i=4 call psb_errpush(info,name,i_err=(/i/)) goto 9999 @@ -2538,25 +2538,25 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_c_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2582,7 +2582,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2600,13 +2600,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2616,20 +2616,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2641,17 +2641,17 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2676,9 +2676,9 @@ end subroutine psb_c_csr_csput_a subroutine psb_c_csr_reinit(a,clear) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_reinit - implicit none + implicit none - class(psb_c_csr_sparse_mat), intent(inout) :: a + class(psb_c_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2691,16 +2691,16 @@ subroutine psb_c_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = czero call a%set_upd() call a%set_host() @@ -2723,9 +2723,9 @@ subroutine psb_c_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_trim - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz, m + integer(psb_ipk_) :: err_act, info, nz, m character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2738,7 +2738,7 @@ subroutine psb_c_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2752,10 +2752,10 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -2763,13 +2763,13 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='c_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2779,35 +2779,35 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) nz = a%get_nzeros() frmt = psb_c_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -2817,12 +2817,12 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_c_csr_print -subroutine psb_c_cp_csr_from_coo(a,b,info) +subroutine psb_c_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_coo - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b @@ -2840,18 +2840,18 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_c_base_sparse_mat = tmp%psb_c_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -2860,22 +2860,22 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -2891,17 +2891,17 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_c_cp_csr_from_coo -subroutine psb_c_cp_csr_to_coo(a,b,info) +subroutine psb_c_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_to_coo - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b @@ -2940,12 +2940,12 @@ subroutine psb_c_cp_csr_to_coo(a,b,info) end subroutine psb_c_cp_csr_to_coo -subroutine psb_c_mv_csr_to_coo(a,b,info) +subroutine psb_c_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_to_coo - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b @@ -2986,13 +2986,13 @@ end subroutine psb_c_mv_csr_to_coo -subroutine psb_c_mv_csr_from_coo(a,b,info) +subroutine psb_c_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_coo - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b @@ -3018,7 +3018,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -3042,15 +3042,15 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_c_mv_csr_from_coo -subroutine psb_c_mv_csr_to_fmt(a,b,info) +subroutine psb_c_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_to_fmt - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b @@ -3067,9 +3067,9 @@ subroutine psb_c_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_c_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat @@ -3087,12 +3087,12 @@ subroutine psb_c_mv_csr_to_fmt(a,b,info) end subroutine psb_c_mv_csr_to_fmt -subroutine psb_c_cp_csr_to_fmt(a,b,info) +subroutine psb_c_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_to_fmt - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b @@ -3110,10 +3110,10 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_c_csr_sparse_mat) + type is (psb_c_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat nr = a%get_nrows() @@ -3131,11 +3131,11 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info) end subroutine psb_c_cp_csr_to_fmt -subroutine psb_c_mv_csr_from_fmt(a,b,info) +subroutine psb_c_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_mv_csr_from_fmt - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b @@ -3152,10 +3152,10 @@ subroutine psb_c_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_c_csr_sparse_mat) + type is (psb_c_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat @@ -3174,12 +3174,12 @@ end subroutine psb_c_mv_csr_from_fmt -subroutine psb_c_cp_csr_from_fmt(a,b,info) +subroutine psb_c_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_cp_csr_from_fmt - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b @@ -3196,10 +3196,10 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_c_coo_sparse_mat) + type is (psb_c_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_c_csr_sparse_mat) + type is (psb_c_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat nr = b%get_nrows() @@ -3218,19 +3218,19 @@ end subroutine psb_c_cp_csr_from_fmt subroutine psb_c_csr_clean_zeros(a, info) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_clean_zeros - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nr - integer(psb_ipk_), allocatable :: ilrp(:) - + integer(psb_ipk_), allocatable :: ilrp(:) + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= czero) then @@ -3249,7 +3249,7 @@ subroutine psb_ccsrspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_ccsrspspmm - implicit none + implicit none class(psb_c_csr_sparse_mat), intent(in) :: a,b type(psb_c_csr_sparse_mat), intent(out) :: c @@ -3260,7 +3260,7 @@ subroutine psb_ccsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -3270,7 +3270,7 @@ subroutine psb_ccsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -3296,9 +3296,9 @@ subroutine psb_ccsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_c_csr_sparse_mat), intent(in) :: a,b type(psb_c_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -3321,49 +3321,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_ccsrspspmm @@ -3372,13 +3372,13 @@ end subroutine psb_ccsrspspmm ! ! ! lc version -! ! -subroutine psb_lc_csr_get_diag(a,d,info) +! +subroutine psb_lc_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_get_diag - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3393,28 +3393,28 @@ subroutine psb_lc_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = cone else do i=1, mnm d(i) = czero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = czero end do @@ -3427,12 +3427,12 @@ subroutine psb_lc_csr_get_diag(a,d,info) end subroutine psb_lc_csr_get_diag -subroutine psb_lc_csr_scal(d,a,info,side) +subroutine psb_lc_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_scal use psb_string_mod - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3442,47 +3442,47 @@ subroutine psb_lc_csr_scal(d,a,info,side) integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -3500,11 +3500,11 @@ subroutine psb_lc_csr_scal(d,a,info,side) end subroutine psb_lc_csr_scal -subroutine psb_lc_csr_scals(d,a,info) +subroutine psb_lc_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_scals - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3518,7 +3518,7 @@ subroutine psb_lc_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3539,7 +3539,7 @@ end subroutine psb_lc_csr_scals function psb_lc_csr_maxval(a) result(res) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_maxval - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3552,7 +3552,7 @@ function psb_lc_csr_maxval(a) result(res) res = szero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3561,7 +3561,7 @@ end function psb_lc_csr_maxval function psb_lc_csr_csnmi(a) result(res) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csnmi - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3578,7 +3578,7 @@ function psb_lc_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -3586,7 +3586,7 @@ function psb_lc_csr_csnmi(a) result(res) end function psb_lc_csr_csnmi -subroutine psb_lc_csr_rowsum(d,a) +subroutine psb_lc_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_rowsum @@ -3606,7 +3606,7 @@ subroutine psb_lc_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3615,12 +3615,12 @@ subroutine psb_lc_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = czero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + cone end do @@ -3628,7 +3628,7 @@ subroutine psb_lc_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3636,7 +3636,7 @@ subroutine psb_lc_csr_rowsum(d,a) end subroutine psb_lc_csr_rowsum -subroutine psb_lc_csr_arwsum(d,a) +subroutine psb_lc_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_arwsum @@ -3656,7 +3656,7 @@ subroutine psb_lc_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3666,19 +3666,19 @@ subroutine psb_lc_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3686,7 +3686,7 @@ subroutine psb_lc_csr_arwsum(d,a) end subroutine psb_lc_csr_arwsum -subroutine psb_lc_csr_colsum(d,a) +subroutine psb_lc_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_colsum @@ -3707,7 +3707,7 @@ subroutine psb_lc_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3722,8 +3722,8 @@ subroutine psb_lc_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + cone end do @@ -3731,7 +3731,7 @@ subroutine psb_lc_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3739,7 +3739,7 @@ subroutine psb_lc_csr_colsum(d,a) end subroutine psb_lc_csr_colsum -subroutine psb_lc_csr_aclsum(d,a) +subroutine psb_lc_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_aclsum @@ -3760,7 +3760,7 @@ subroutine psb_lc_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3775,8 +3775,8 @@ subroutine psb_lc_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + sone end do @@ -3784,7 +3784,7 @@ subroutine psb_lc_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3793,7 +3793,7 @@ subroutine psb_lc_csr_aclsum(d,a) end subroutine psb_lc_csr_aclsum -! == =================================== +! == =================================== ! ! ! @@ -3803,14 +3803,14 @@ end subroutine psb_lc_csr_aclsum ! ! ! -! == =================================== +! == =================================== -subroutine psb_lc_csr_reallocate_nz(nz,a) +subroutine psb_lc_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_reallocate_nz - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lc_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3822,7 +3822,7 @@ subroutine psb_lc_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -3836,10 +3836,10 @@ subroutine psb_lc_csr_reallocate_nz(nz,a) end subroutine psb_lc_csr_reallocate_nz -subroutine psb_lc_csr_mold(a,b,info) +subroutine psb_lc_csr_mold(a,b,info) use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_mold use psb_error_mod - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3848,16 +3848,16 @@ subroutine psb_lc_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_lc_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -3868,11 +3868,11 @@ subroutine psb_lc_csr_mold(a,b,info) end subroutine psb_lc_csr_mold -subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_lc_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -3884,26 +3884,26 @@ subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -3911,7 +3911,7 @@ subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -3934,7 +3934,7 @@ end subroutine psb_lc_csr_allocate_mnnz subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3952,7 +3952,7 @@ subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -3981,35 +3981,35 @@ subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4055,32 +4055,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -4091,7 +4091,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -4102,13 +4102,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_lc_csr_csgetptn subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4127,7 +4127,7 @@ subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -4137,7 +4137,7 @@ subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -4156,22 +4156,22 @@ subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -4179,13 +4179,13 @@ subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4232,12 +4232,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -4245,21 +4245,21 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4271,7 +4271,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4292,7 +4292,7 @@ end subroutine psb_lc_csr_csgetrow ! subroutine psb_lc_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_tril @@ -4304,7 +4304,7 @@ subroutine psb_lc_csr_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lc_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4316,57 +4316,57 @@ subroutine psb_lc_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -4375,7 +4375,7 @@ subroutine psb_lc_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -4391,7 +4391,7 @@ subroutine psb_lc_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -4399,17 +4399,17 @@ subroutine psb_lc_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -4428,8 +4428,8 @@ subroutine psb_lc_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -4447,7 +4447,7 @@ end subroutine psb_lc_csr_tril subroutine psb_lc_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_triu @@ -4459,7 +4459,7 @@ subroutine psb_lc_csr_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lc_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4471,57 +4471,57 @@ subroutine psb_lc_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -4530,7 +4530,7 @@ subroutine psb_lc_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -4582,8 +4582,8 @@ subroutine psb_lc_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -4600,11 +4600,11 @@ subroutine psb_lc_csr_triu(a,u,info,& end subroutine psb_lc_csr_triu -subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csput_a - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) @@ -4624,24 +4624,24 @@ subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then - info = psb_err_iarg_neg_; + if (nz <= 0) then + info = psb_err_iarg_neg_; call psb_errpush(info,name,m_err=(/1/)) goto 9999 end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/2/)) goto 9999 end if - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/3/)) goto 9999 end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/4/)) goto 9999 end if @@ -4651,25 +4651,25 @@ subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_lc_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -4695,7 +4695,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -4713,13 +4713,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -4729,20 +4729,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 inc = nc - ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -4754,18 +4754,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 inc = nc ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -4790,9 +4790,9 @@ end subroutine psb_lc_csr_csput_a subroutine psb_lc_csr_reinit(a,clear) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_reinit - implicit none + implicit none - class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4805,16 +4805,16 @@ subroutine psb_lc_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = czero call a%set_upd() call a%set_host() @@ -4837,7 +4837,7 @@ subroutine psb_lc_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_trim - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, m integer(psb_ipk_) :: err_act, info @@ -4853,7 +4853,7 @@ subroutine psb_lc_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4866,10 +4866,10 @@ end subroutine psb_lc_csr_trim subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4877,13 +4877,13 @@ subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='lc_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4892,36 +4892,36 @@ subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_lc_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -4931,12 +4931,12 @@ subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_lc_csr_print -subroutine psb_lc_cp_csr_from_coo(a,b,info) +subroutine psb_lc_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_from_coo - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(in) :: b @@ -4954,18 +4954,18 @@ subroutine psb_lc_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_lc_base_sparse_mat = tmp%psb_lc_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -4974,22 +4974,22 @@ subroutine psb_lc_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -5005,17 +5005,17 @@ subroutine psb_lc_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_lc_cp_csr_from_coo -subroutine psb_lc_cp_csr_to_coo(a,b,info) +subroutine psb_lc_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_to_coo - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -5054,12 +5054,12 @@ subroutine psb_lc_cp_csr_to_coo(a,b,info) end subroutine psb_lc_cp_csr_to_coo -subroutine psb_lc_mv_csr_to_coo(a,b,info) +subroutine psb_lc_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_to_coo - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -5100,13 +5100,13 @@ end subroutine psb_lc_mv_csr_to_coo -subroutine psb_lc_mv_csr_from_coo(a,b,info) +subroutine psb_lc_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_from_coo - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_coo_sparse_mat), intent(inout) :: b @@ -5132,7 +5132,7 @@ subroutine psb_lc_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -5156,15 +5156,15 @@ subroutine psb_lc_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_lc_mv_csr_from_coo -subroutine psb_lc_mv_csr_to_fmt(a,b,info) +subroutine psb_lc_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_to_fmt - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b @@ -5181,9 +5181,9 @@ subroutine psb_lc_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_lc_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat @@ -5201,12 +5201,12 @@ subroutine psb_lc_mv_csr_to_fmt(a,b,info) end subroutine psb_lc_mv_csr_to_fmt -subroutine psb_lc_cp_csr_to_fmt(a,b,info) +subroutine psb_lc_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_to_fmt - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b @@ -5224,10 +5224,10 @@ subroutine psb_lc_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_lc_csr_sparse_mat) + type is (psb_lc_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat nr = a%get_nrows() @@ -5245,11 +5245,11 @@ subroutine psb_lc_cp_csr_to_fmt(a,b,info) end subroutine psb_lc_cp_csr_to_fmt -subroutine psb_lc_mv_csr_from_fmt(a,b,info) +subroutine psb_lc_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_from_fmt - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b @@ -5266,10 +5266,10 @@ subroutine psb_lc_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_lc_csr_sparse_mat) + type is (psb_lc_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat @@ -5288,12 +5288,12 @@ end subroutine psb_lc_mv_csr_from_fmt -subroutine psb_lc_cp_csr_from_fmt(a,b,info) +subroutine psb_lc_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_c_base_mat_mod use psb_realloc_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_from_fmt - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(in) :: b @@ -5310,10 +5310,10 @@ subroutine psb_lc_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lc_coo_sparse_mat) + type is (psb_lc_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_lc_csr_sparse_mat) + type is (psb_lc_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat nr = b%get_nrows() @@ -5333,19 +5333,19 @@ end subroutine psb_lc_cp_csr_from_fmt subroutine psb_lc_csr_clean_zeros(a, info) use psb_error_mod use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_clean_zeros - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nr - integer(psb_lpk_), allocatable :: ilrp(:) - - info = 0 + integer(psb_lpk_), allocatable :: ilrp(:) + + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= czero) then @@ -5364,7 +5364,7 @@ subroutine psb_lccsrspspmm(a,b,c,info) use psb_c_mat_mod use psb_serial_mod, psb_protect_name => psb_lccsrspspmm - implicit none + implicit none class(psb_lc_csr_sparse_mat), intent(in) :: a,b type(psb_lc_csr_sparse_mat), intent(out) :: c @@ -5375,7 +5375,7 @@ subroutine psb_lccsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -5385,7 +5385,7 @@ subroutine psb_lccsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -5410,9 +5410,9 @@ subroutine psb_lccsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_lc_csr_sparse_mat), intent(in) :: a,b type(psb_lc_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -5435,50 +5435,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_lccsrspspmm - diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 5b478c770..69c67d028 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! c_mat_impl: ! implementation of the outer matrix methods. @@ -43,7 +43,7 @@ ! ! ! -! Setters +! Setters ! ! ! @@ -53,10 +53,10 @@ ! == =================================== -subroutine psb_c_set_nrows(m,a) +subroutine psb_c_set_nrows(m,a) use psb_c_mat_mod, psb_protect_name => psb_c_set_nrows use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -64,7 +64,7 @@ subroutine psb_c_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -82,10 +82,10 @@ subroutine psb_c_set_nrows(m,a) end subroutine psb_c_set_nrows -subroutine psb_c_set_ncols(n,a) +subroutine psb_c_set_ncols(n,a) use psb_c_mat_mod, psb_protect_name => psb_c_set_ncols use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -93,7 +93,7 @@ subroutine psb_c_set_ncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -112,16 +112,16 @@ end subroutine psb_c_set_ncols ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_c_set_dupl(n,a) +subroutine psb_c_set_dupl(n,a) use psb_c_mat_mod, psb_protect_name => psb_c_set_dupl use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -129,7 +129,7 @@ subroutine psb_c_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -151,17 +151,17 @@ end subroutine psb_c_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_c_set_null(a) +subroutine psb_c_set_null(a) use psb_c_mat_mod, psb_protect_name => psb_c_set_null use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -179,17 +179,17 @@ subroutine psb_c_set_null(a) end subroutine psb_c_set_null -subroutine psb_c_set_bld(a) +subroutine psb_c_set_bld(a) use psb_c_mat_mod, psb_protect_name => psb_c_set_bld use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -208,17 +208,17 @@ subroutine psb_c_set_bld(a) end subroutine psb_c_set_bld -subroutine psb_c_set_upd(a) +subroutine psb_c_set_upd(a) use psb_c_mat_mod, psb_protect_name => psb_c_set_upd use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -238,17 +238,17 @@ subroutine psb_c_set_upd(a) end subroutine psb_c_set_upd -subroutine psb_c_set_asb(a) +subroutine psb_c_set_asb(a) use psb_c_mat_mod, psb_protect_name => psb_c_set_asb use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -267,10 +267,10 @@ subroutine psb_c_set_asb(a) end subroutine psb_c_set_asb -subroutine psb_c_set_sorted(a,val) +subroutine psb_c_set_sorted(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_sorted use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -278,7 +278,7 @@ subroutine psb_c_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -297,10 +297,10 @@ subroutine psb_c_set_sorted(a,val) end subroutine psb_c_set_sorted -subroutine psb_c_set_triangle(a,val) +subroutine psb_c_set_triangle(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_triangle use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -308,7 +308,7 @@ subroutine psb_c_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -326,10 +326,10 @@ subroutine psb_c_set_triangle(a,val) end subroutine psb_c_set_triangle -subroutine psb_c_set_symmetric(a,val) +subroutine psb_c_set_symmetric(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -337,7 +337,7 @@ subroutine psb_c_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -355,10 +355,10 @@ subroutine psb_c_set_symmetric(a,val) end subroutine psb_c_set_symmetric -subroutine psb_c_set_unit(a,val) +subroutine psb_c_set_unit(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_unit use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -366,7 +366,7 @@ subroutine psb_c_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -385,10 +385,10 @@ subroutine psb_c_set_unit(a,val) end subroutine psb_c_set_unit -subroutine psb_c_set_lower(a,val) +subroutine psb_c_set_lower(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_lower use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -396,7 +396,7 @@ subroutine psb_c_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -415,10 +415,10 @@ subroutine psb_c_set_lower(a,val) end subroutine psb_c_set_lower -subroutine psb_c_set_upper(a,val) +subroutine psb_c_set_upper(a,val) use psb_c_mat_mod, psb_protect_name => psb_c_set_upper use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -426,7 +426,7 @@ subroutine psb_c_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -456,16 +456,16 @@ end subroutine psb_c_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) use psb_c_mat_mod, psb_protect_name => psb_c_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -476,7 +476,7 @@ subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -496,10 +496,10 @@ end subroutine psb_c_sparse_print subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_c_mat_mod, psb_protect_name => psb_c_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_cspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_cspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -511,24 +511,24 @@ subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -547,13 +547,13 @@ end subroutine psb_c_n_sparse_print subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) use psb_c_mat_mod, psb_protect_name => psb_c_get_neigh use psb_error_mod - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -561,7 +561,7 @@ subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -582,17 +582,17 @@ end subroutine psb_c_get_neigh -subroutine psb_c_csall(nr,nc,a,info,nz) +subroutine psb_c_csall(nr,nc,a,info,nz) use psb_c_mat_mod, psb_protect_name => psb_c_csall use psb_c_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -602,13 +602,13 @@ subroutine psb_c_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_c_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -619,10 +619,10 @@ subroutine psb_c_csall(nr,nc,a,info,nz) end subroutine psb_c_csall -subroutine psb_c_reallocate_nz(nz,a) +subroutine psb_c_reallocate_nz(nz,a) use psb_c_mat_mod, psb_protect_name => psb_c_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -630,7 +630,7 @@ subroutine psb_c_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -647,31 +647,31 @@ subroutine psb_c_reallocate_nz(nz,a) end subroutine psb_c_reallocate_nz -subroutine psb_c_free(a) +subroutine psb_c_free(a) use psb_c_mat_mod, psb_protect_name => psb_c_free use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_c_free -subroutine psb_c_trim(a) +subroutine psb_c_trim(a) use psb_c_mat_mod, psb_protect_name => psb_c_trim use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -689,11 +689,11 @@ end subroutine psb_c_trim -subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_mat_mod, psb_protect_name => psb_c_csput_a use psb_c_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -705,15 +705,15 @@ subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -725,13 +725,13 @@ subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_c_csput_a -subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_mat_mod, psb_protect_name => psb_c_csput_v use psb_c_base_mat_mod use psb_c_vect_mod, only : psb_c_vect_type use psb_i_vect_mod, only : psb_i_vect_type use psb_error_mod - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a type(psb_c_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -744,19 +744,19 @@ subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -771,7 +771,7 @@ end subroutine psb_c_csput_v subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -794,7 +794,7 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -803,7 +803,7 @@ subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -818,7 +818,7 @@ end subroutine psb_c_csgetptn subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -842,7 +842,7 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -851,7 +851,7 @@ subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -868,7 +868,7 @@ end subroutine psb_c_csgetrow subroutine psb_c_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -893,31 +893,31 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -936,7 +936,7 @@ subroutine psb_c_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_c_base_mat_mod use psb_c_mat_mod, psb_protect_name => psb_c_tril - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -951,22 +951,22 @@ subroutine psb_c_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -975,7 +975,7 @@ subroutine psb_c_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -993,7 +993,7 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_c_base_mat_mod use psb_c_mat_mod, psb_protect_name => psb_c_triu - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -1009,24 +1009,24 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -1035,7 +1035,7 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1047,9 +1047,10 @@ subroutine psb_c_triu(a,u,info,diag,imin,imax,& end subroutine psb_c_triu + subroutine psb_c_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -1069,24 +1070,24 @@ subroutine psb_c_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1099,7 +1100,7 @@ end subroutine psb_c_csclip subroutine psb_c_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -1118,14 +1119,14 @@ subroutine psb_c_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -1133,8 +1134,8 @@ subroutine psb_c_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1147,7 +1148,7 @@ end subroutine psb_c_csclip_ip subroutine psb_c_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -1166,7 +1167,7 @@ subroutine psb_c_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1174,7 +1175,7 @@ subroutine psb_c_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1190,7 +1191,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_cscnv - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1207,7 +1208,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1219,38 +1220,38 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_c_coo_sparse_mat :: altmp, stat=info) + allocate(psb_c_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_c_csc_sparse_mat :: altmp, stat=info) + allocate(psb_c_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -1268,7 +1269,7 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%set_asb() + call b%set_asb() call psb_erractionrestore(err_act) return @@ -1283,7 +1284,7 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_ip - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -1300,15 +1301,15 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -1318,29 +1319,29 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_c_csr_sparse_mat :: altmp, stat=info) + allocate(psb_c_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_c_coo_sparse_mat :: altmp, stat=info) + allocate(psb_c_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_c_csc_sparse_mat :: altmp, stat=info) + allocate(psb_c_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1359,7 +1360,7 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) call move_alloc(altmp,a%a) call a%trim() - call a%set_asb() + call a%set_asb() call psb_erractionrestore(err_act) return @@ -1376,7 +1377,7 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_base - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -1391,19 +1392,19 @@ subroutine psb_c_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -1425,7 +1426,7 @@ end subroutine psb_c_cscnv_base subroutine psb_c_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -1444,15 +1445,15 @@ subroutine psb_c_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1461,8 +1462,8 @@ subroutine psb_c_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1485,7 +1486,7 @@ end subroutine psb_c_clip_d subroutine psb_c_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -1503,13 +1504,13 @@ subroutine psb_c_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -1520,8 +1521,8 @@ subroutine psb_c_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1546,7 +1547,7 @@ subroutine psb_c_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_mv_from - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1564,7 +1565,7 @@ subroutine psb_c_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_from - implicit none + implicit none class(psb_cspmat_type), intent(out) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -1573,7 +1574,7 @@ subroutine psb_c_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -1582,8 +1583,8 @@ subroutine psb_c_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1599,11 +1600,11 @@ subroutine psb_c_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_mv_to - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -1614,7 +1615,7 @@ subroutine psb_c_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_to - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1631,14 +1632,14 @@ subroutine psb_c_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_c_mold subroutine psb_cspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_cspmat_type_move - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1659,7 +1660,7 @@ subroutine psb_cspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_cspmat_clone - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1671,10 +1672,10 @@ subroutine psb_cspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1691,7 +1692,7 @@ subroutine psb_c_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_transp_1mat - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1700,7 +1701,7 @@ subroutine psb_c_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1724,7 +1725,7 @@ subroutine psb_c_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_transp_2mat - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b @@ -1734,18 +1735,18 @@ subroutine psb_c_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -1762,7 +1763,7 @@ subroutine psb_c_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_transc_1mat - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1771,7 +1772,7 @@ subroutine psb_c_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1795,7 +1796,7 @@ subroutine psb_c_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_c_transc_2mat - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b @@ -1805,18 +1806,18 @@ subroutine psb_c_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -1832,9 +1833,9 @@ end subroutine psb_c_transc_2mat subroutine psb_c_asb(a,mold) use psb_c_mat_mod, psb_protect_name => psb_c_asb use psb_error_mod - implicit none + implicit none - class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), optional, intent(in) :: mold class(psb_c_base_sparse_mat), allocatable :: tmp class(psb_c_base_sparse_mat), pointer :: mld @@ -1842,15 +1843,15 @@ subroutine psb_c_asb(a,mold) character(len=20) :: name='c_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -1861,7 +1862,7 @@ subroutine psb_c_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -1876,21 +1877,21 @@ end subroutine psb_c_asb subroutine psb_c_reinit(a,clear) use psb_c_mat_mod, psb_protect_name => psb_c_reinit use psb_error_mod - implicit none + implicit none - class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -1925,10 +1926,10 @@ end subroutine psb_c_reinit ! == =================================== -subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_c_mat_mod, psb_protect_name => psb_c_csmm - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1940,14 +1941,14 @@ subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1958,10 +1959,10 @@ subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_c_csmm -subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_c_mat_mod, psb_protect_name => psb_c_csmv - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1973,14 +1974,14 @@ subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1990,11 +1991,11 @@ subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_c_csmv -subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) +subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_c_vect_mod use psb_c_mat_mod, psb_protect_name => psb_c_csmv_vect - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta type(psb_c_vect_type), intent(inout) :: x @@ -2007,25 +2008,25 @@ subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x%v,beta,y%v,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2037,10 +2038,10 @@ end subroutine psb_c_csmv_vect -subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_c_mat_mod, psb_protect_name => psb_c_cssm - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -2053,14 +2054,14 @@ subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2072,10 +2073,10 @@ subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_c_cssm -subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_c_mat_mod, psb_protect_name => psb_c_cssv - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -2088,15 +2089,15 @@ subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2108,11 +2109,11 @@ subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_c_cssv -subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_c_vect_mod use psb_c_mat_mod, psb_protect_name => psb_c_cssv_vect - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta type(psb_c_vect_type), intent(inout) :: x @@ -2126,33 +2127,33 @@ subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then + if (present(d)) then + if (.not.allocated(d%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2167,7 +2168,7 @@ function psb_c_maxval(a) result(res) use psb_c_mat_mod, psb_protect_name => psb_c_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -2178,7 +2179,7 @@ function psb_c_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2198,7 +2199,7 @@ function psb_c_csnmi(a) result(res) use psb_c_mat_mod, psb_protect_name => psb_c_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -2208,7 +2209,7 @@ function psb_c_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2229,7 +2230,7 @@ function psb_c_csnm1(a) result(res) use psb_c_mat_mod, psb_protect_name => psb_c_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -2239,7 +2240,7 @@ function psb_c_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2260,7 +2261,7 @@ function psb_c_rowsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_c_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2272,7 @@ function psb_c_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2293,7 +2294,7 @@ function psb_c_arwsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_c_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2304,7 +2305,7 @@ function psb_c_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2327,7 +2328,7 @@ function psb_c_colsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_c_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2338,7 +2339,7 @@ function psb_c_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2361,7 +2362,7 @@ function psb_c_aclsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_c_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2372,7 +2373,7 @@ function psb_c_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2396,7 +2397,7 @@ function psb_c_get_diag(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_c_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2407,14 +2408,14 @@ function psb_c_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -2435,7 +2436,7 @@ subroutine psb_c_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_scal - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2447,7 +2448,7 @@ subroutine psb_c_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2470,7 +2471,7 @@ subroutine psb_c_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_scals - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -2481,7 +2482,7 @@ subroutine psb_c_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2499,12 +2500,152 @@ subroutine psb_c_scals(d,a,info) end subroutine psb_c_scals +subroutine psb_c_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_scalplusidentity + implicit none + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_scalplusidentity + +subroutine psb_c_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_spaxpby + implicit none + complex(psb_spk_), intent(in) :: alpha + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: beta + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_spaxpby + +function psb_c_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cmpval + implicit none + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_c_cmpval + +function psb_c_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cmpmat + implicit none + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_c_cmpmat + subroutine psb_c_mv_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_mv_from_lb - implicit none - + implicit none + class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2512,16 +2653,16 @@ subroutine psb_c_mv_from_lb(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) - + end subroutine psb_c_mv_from_lb - + subroutine psb_c_cp_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_from_lb - implicit none - + implicit none + class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2536,30 +2677,30 @@ subroutine psb_c_mv_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_mv_to_lb - implicit none - + implicit none + class(psb_cspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_lfmt(b,info) call a%free() end if - + end subroutine psb_c_mv_to_lb subroutine psb_c_cp_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_to_lb - implicit none + implicit none class(psb_cspmat_type), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -2572,7 +2713,7 @@ subroutine psb_c_mv_from_l(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_mv_from_l - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -2585,21 +2726,21 @@ subroutine psb_c_mv_from_l(a,b) call a%free() end if call b%free() - + end subroutine psb_c_mv_from_l - + subroutine psb_c_cp_from_l(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_from_l - implicit none + implicit none class(psb_cspmat_type), intent(out) :: a class(psb_lcspmat_type), intent(in) :: b integer(psb_ipk_) :: info - info = psb_success_ + info = psb_success_ if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_lfmt(b%a,info) @@ -2612,12 +2753,12 @@ subroutine psb_c_mv_to_l(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_mv_to_l - implicit none + implicit none class(psb_cspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_lc_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_lfmt(b%a,info) @@ -2625,26 +2766,26 @@ subroutine psb_c_mv_to_l(a,b) call b%free() end if call a%free() - + end subroutine psb_c_mv_to_l subroutine psb_c_cp_to_l(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_c_cp_to_l - implicit none - + implicit none + class(psb_cspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_lc_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_lfmt(b%a,info) else call b%free() end if - + end subroutine psb_c_cp_to_l @@ -2654,10 +2795,10 @@ end subroutine psb_c_cp_to_l ! -subroutine psb_lc_set_lnrows(m,a) +subroutine psb_lc_set_lnrows(m,a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_lnrows use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2665,7 +2806,7 @@ subroutine psb_lc_set_lnrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2683,10 +2824,10 @@ subroutine psb_lc_set_lnrows(m,a) end subroutine psb_lc_set_lnrows #if defined(IPK4) && defined(LPK8) -subroutine psb_lc_set_inrows(m,a) +subroutine psb_lc_set_inrows(m,a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_inrows use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2694,7 +2835,7 @@ subroutine psb_lc_set_inrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2712,10 +2853,10 @@ subroutine psb_lc_set_inrows(m,a) end subroutine psb_lc_set_inrows #endif -subroutine psb_lc_set_lncols(n,a) +subroutine psb_lc_set_lncols(n,a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_lncols use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2723,7 +2864,7 @@ subroutine psb_lc_set_lncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2740,10 +2881,10 @@ subroutine psb_lc_set_lncols(n,a) end subroutine psb_lc_set_lncols #if defined(IPK4) && defined(LPK8) -subroutine psb_lc_set_incols(n,a) +subroutine psb_lc_set_incols(n,a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_incols use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2751,7 +2892,7 @@ subroutine psb_lc_set_incols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2770,16 +2911,16 @@ end subroutine psb_lc_set_incols #endif ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_lc_set_dupl(n,a) +subroutine psb_lc_set_dupl(n,a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_dupl use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2787,7 +2928,7 @@ subroutine psb_lc_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2809,17 +2950,17 @@ end subroutine psb_lc_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_lc_set_null(a) +subroutine psb_lc_set_null(a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_null use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2837,17 +2978,17 @@ subroutine psb_lc_set_null(a) end subroutine psb_lc_set_null -subroutine psb_lc_set_bld(a) +subroutine psb_lc_set_bld(a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_bld use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2866,17 +3007,17 @@ subroutine psb_lc_set_bld(a) end subroutine psb_lc_set_bld -subroutine psb_lc_set_upd(a) +subroutine psb_lc_set_upd(a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_upd use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2896,17 +3037,17 @@ subroutine psb_lc_set_upd(a) end subroutine psb_lc_set_upd -subroutine psb_lc_set_asb(a) +subroutine psb_lc_set_asb(a) use psb_c_mat_mod, psb_protect_name => psb_lc_set_asb use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2925,10 +3066,10 @@ subroutine psb_lc_set_asb(a) end subroutine psb_lc_set_asb -subroutine psb_lc_set_sorted(a,val) +subroutine psb_lc_set_sorted(a,val) use psb_c_mat_mod, psb_protect_name => psb_lc_set_sorted use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2936,7 +3077,7 @@ subroutine psb_lc_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2955,10 +3096,10 @@ subroutine psb_lc_set_sorted(a,val) end subroutine psb_lc_set_sorted -subroutine psb_lc_set_triangle(a,val) +subroutine psb_lc_set_triangle(a,val) use psb_c_mat_mod, psb_protect_name => psb_lc_set_triangle use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2966,7 +3107,7 @@ subroutine psb_lc_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2984,10 +3125,10 @@ subroutine psb_lc_set_triangle(a,val) end subroutine psb_lc_set_triangle -subroutine psb_lc_set_symmetric(a,val) +subroutine psb_lc_set_symmetric(a,val) use psb_c_mat_mod, psb_protect_name => psb_lc_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2995,7 +3136,7 @@ subroutine psb_lc_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3013,10 +3154,10 @@ subroutine psb_lc_set_symmetric(a,val) end subroutine psb_lc_set_symmetric -subroutine psb_lc_set_unit(a,val) +subroutine psb_lc_set_unit(a,val) use psb_c_mat_mod, psb_protect_name => psb_lc_set_unit use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3024,7 +3165,7 @@ subroutine psb_lc_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3043,10 +3184,10 @@ subroutine psb_lc_set_unit(a,val) end subroutine psb_lc_set_unit -subroutine psb_lc_set_lower(a,val) +subroutine psb_lc_set_lower(a,val) use psb_c_mat_mod, psb_protect_name => psb_lc_set_lower use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3054,7 +3195,7 @@ subroutine psb_lc_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3073,10 +3214,10 @@ subroutine psb_lc_set_lower(a,val) end subroutine psb_lc_set_lower -subroutine psb_lc_set_upper(a,val) +subroutine psb_lc_set_upper(a,val) use psb_c_mat_mod, psb_protect_name => psb_lc_set_upper use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3084,7 +3225,7 @@ subroutine psb_lc_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3114,16 +3255,16 @@ end subroutine psb_lc_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) use psb_c_mat_mod, psb_protect_name => psb_lc_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3134,7 +3275,7 @@ subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3154,10 +3295,10 @@ end subroutine psb_lc_sparse_print subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_c_mat_mod, psb_protect_name => psb_lc_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_lcspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_lcspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3169,24 +3310,24 @@ subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -3205,13 +3346,13 @@ end subroutine psb_lc_n_sparse_print subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) use psb_c_mat_mod, psb_protect_name => psb_lc_get_neigh use psb_error_mod - implicit none - class(psb_lcspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -3219,7 +3360,7 @@ subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3240,17 +3381,17 @@ end subroutine psb_lc_get_neigh -subroutine psb_lc_csall(nr,nc,a,info,nz) +subroutine psb_lc_csall(nr,nc,a,info,nz) use psb_c_mat_mod, psb_protect_name => psb_lc_csall use psb_c_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -3260,13 +3401,13 @@ subroutine psb_lc_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -3277,10 +3418,10 @@ subroutine psb_lc_csall(nr,nc,a,info,nz) end subroutine psb_lc_csall -subroutine psb_lc_reallocate_nz(nz,a) +subroutine psb_lc_reallocate_nz(nz,a) use psb_c_mat_mod, psb_protect_name => psb_lc_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3288,7 +3429,7 @@ subroutine psb_lc_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3305,31 +3446,31 @@ subroutine psb_lc_reallocate_nz(nz,a) end subroutine psb_lc_reallocate_nz -subroutine psb_lc_free(a) +subroutine psb_lc_free(a) use psb_c_mat_mod, psb_protect_name => psb_lc_free use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_lc_free -subroutine psb_lc_trim(a) +subroutine psb_lc_trim(a) use psb_c_mat_mod, psb_protect_name => psb_lc_trim use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3347,11 +3488,11 @@ end subroutine psb_lc_trim -subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_mat_mod, psb_protect_name => psb_lc_csput_a use psb_c_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -3363,15 +3504,15 @@ subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3383,13 +3524,13 @@ subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_lc_csput_a -subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_c_mat_mod, psb_protect_name => psb_lc_csput_v use psb_c_base_mat_mod use psb_c_vect_mod, only : psb_c_vect_type use psb_l_vect_mod, only : psb_l_vect_type use psb_error_mod - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a type(psb_c_vect_type), intent(inout) :: val type(psb_l_vect_type), intent(inout) :: ia, ja @@ -3402,19 +3543,19 @@ subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3429,7 +3570,7 @@ end subroutine psb_lc_csput_v subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -3452,7 +3593,7 @@ subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3461,7 +3602,7 @@ subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3476,7 +3617,7 @@ end subroutine psb_lc_csgetptn subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -3500,7 +3641,7 @@ subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3509,7 +3650,7 @@ subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3526,7 +3667,7 @@ end subroutine psb_lc_csgetrow subroutine psb_lc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -3551,31 +3692,31 @@ subroutine psb_lc_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3594,7 +3735,7 @@ subroutine psb_lc_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_c_base_mat_mod use psb_c_mat_mod, psb_protect_name => psb_lc_tril - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -3609,22 +3750,22 @@ subroutine psb_lc_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3633,7 +3774,7 @@ subroutine psb_lc_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3651,7 +3792,7 @@ subroutine psb_lc_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_c_base_mat_mod use psb_c_mat_mod, psb_protect_name => psb_lc_triu - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -3667,24 +3808,24 @@ subroutine psb_lc_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3693,7 +3834,7 @@ subroutine psb_lc_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3708,7 +3849,7 @@ end subroutine psb_lc_triu subroutine psb_lc_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -3728,24 +3869,24 @@ subroutine psb_lc_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3758,7 +3899,7 @@ end subroutine psb_lc_csclip subroutine psb_lc_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -3777,14 +3918,14 @@ subroutine psb_lc_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -3792,8 +3933,8 @@ subroutine psb_lc_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3806,7 +3947,7 @@ end subroutine psb_lc_csclip_ip subroutine psb_lc_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -3825,7 +3966,7 @@ subroutine psb_lc_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3833,7 +3974,7 @@ subroutine psb_lc_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3852,7 +3993,7 @@ subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3869,7 +4010,7 @@ subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3881,38 +4022,38 @@ subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) + allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) + allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) + allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -3930,7 +4071,7 @@ subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%asb() + call b%asb() call psb_erractionrestore(err_act) return @@ -3947,7 +4088,7 @@ subroutine psb_lc_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv_ip - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3964,15 +4105,15 @@ subroutine psb_lc_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -3982,29 +4123,29 @@ subroutine psb_lc_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) + allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) + allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) + allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4022,7 +4163,7 @@ subroutine psb_lc_cscnv_ip(a,info,type,mold,dupl) end if call move_alloc(altmp,a%a) - call a%set_asb() + call a%set_asb() call a%trim() call psb_erractionrestore(err_act) return @@ -4040,7 +4181,7 @@ subroutine psb_lc_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv_base - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lc_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -4055,19 +4196,19 @@ subroutine psb_lc_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -4089,7 +4230,7 @@ end subroutine psb_lc_cscnv_base subroutine psb_lc_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -4108,15 +4249,15 @@ subroutine psb_lc_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4125,8 +4266,8 @@ subroutine psb_lc_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4149,7 +4290,7 @@ end subroutine psb_lc_clip_d subroutine psb_lc_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_c_base_mat_mod @@ -4167,13 +4308,13 @@ subroutine psb_lc_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -4184,8 +4325,8 @@ subroutine psb_lc_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4210,7 +4351,7 @@ subroutine psb_lc_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4228,7 +4369,7 @@ subroutine psb_lc_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from - implicit none + implicit none class(psb_lcspmat_type), intent(out) :: a class(psb_lc_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -4237,7 +4378,7 @@ subroutine psb_lc_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -4246,8 +4387,8 @@ subroutine psb_lc_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4263,11 +4404,11 @@ subroutine psb_lc_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -4278,7 +4419,7 @@ subroutine psb_lc_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lc_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4295,14 +4436,14 @@ subroutine psb_lc_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_lc_mold subroutine psb_lcspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lcspmat_type_move - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4323,7 +4464,7 @@ subroutine psb_lcspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lcspmat_clone - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a class(psb_lcspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4335,10 +4476,10 @@ subroutine psb_lcspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4355,7 +4496,7 @@ subroutine psb_lc_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_transp_1mat - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4364,7 +4505,7 @@ subroutine psb_lc_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4388,7 +4529,7 @@ subroutine psb_lc_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_transp_2mat - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: b @@ -4398,18 +4539,18 @@ subroutine psb_lc_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -4426,7 +4567,7 @@ subroutine psb_lc_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_transc_1mat - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4435,7 +4576,7 @@ subroutine psb_lc_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4459,7 +4600,7 @@ subroutine psb_lc_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_c_mat_mod, psb_protect_name => psb_lc_transc_2mat - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_lcspmat_type), intent(inout) :: b @@ -4469,18 +4610,18 @@ subroutine psb_lc_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -4496,9 +4637,9 @@ end subroutine psb_lc_transc_2mat subroutine psb_lc_asb(a,mold) use psb_c_mat_mod, psb_protect_name => psb_lc_asb use psb_error_mod - implicit none + implicit none - class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: a class(psb_lc_base_sparse_mat), optional, intent(in) :: mold class(psb_lc_base_sparse_mat), allocatable :: tmp class(psb_lc_base_sparse_mat), pointer :: mld @@ -4506,15 +4647,15 @@ subroutine psb_lc_asb(a,mold) character(len=20) :: name='lc_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -4525,7 +4666,7 @@ subroutine psb_lc_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -4540,21 +4681,21 @@ end subroutine psb_lc_asb subroutine psb_lc_reinit(a,clear) use psb_c_mat_mod, psb_protect_name => psb_lc_reinit use psb_error_mod - implicit none + implicit none - class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -4579,7 +4720,7 @@ function psb_lc_get_diag(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_lc_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4590,14 +4731,14 @@ function psb_lc_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -4618,7 +4759,7 @@ subroutine psb_lc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_scal - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4630,7 +4771,7 @@ subroutine psb_lc_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4653,7 +4794,7 @@ subroutine psb_lc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_scals - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4664,7 +4805,7 @@ subroutine psb_lc_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4682,11 +4823,151 @@ subroutine psb_lc_scals(d,a,info) end subroutine psb_lc_scals +subroutine psb_lc_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_scalplusidentity + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_scalplusidentity + +subroutine psb_lc_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_spaxpby + implicit none + complex(psb_spk_), intent(in) :: alpha + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: beta + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_spaxpby + +function psb_lc_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cmpval + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_cmpval + +function psb_lc_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cmpmat + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_cmpmat + function psb_lc_maxval(a) result(res) use psb_c_mat_mod, psb_protect_name => psb_lc_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -4697,7 +4978,7 @@ function psb_lc_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4717,7 +4998,7 @@ function psb_lc_csnmi(a) result(res) use psb_c_mat_mod, psb_protect_name => psb_lc_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -4727,7 +5008,7 @@ function psb_lc_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4747,7 +5028,7 @@ function psb_lc_csnm1(a) result(res) use psb_c_mat_mod, psb_protect_name => psb_lc_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -4757,7 +5038,7 @@ function psb_lc_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4778,7 +5059,7 @@ function psb_lc_rowsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_lc_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4789,7 +5070,7 @@ function psb_lc_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4811,7 +5092,7 @@ function psb_lc_arwsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_lc_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4822,7 +5103,7 @@ function psb_lc_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4845,7 +5126,7 @@ function psb_lc_colsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_lc_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a complex(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4856,7 +5137,7 @@ function psb_lc_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4879,7 +5160,7 @@ function psb_lc_aclsum(a,info) result(d) use psb_c_mat_mod, psb_protect_name => psb_lc_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4890,7 +5171,7 @@ function psb_lc_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4913,8 +5194,8 @@ subroutine psb_lc_mv_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from_ib - implicit none - + implicit none + class(psb_lcspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4922,15 +5203,15 @@ subroutine psb_lc_mv_from_ib(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_ifmt(b,info) - + end subroutine psb_lc_mv_from_ib - + subroutine psb_lc_cp_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from_ib - implicit none - + implicit none + class(psb_lcspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4945,30 +5226,30 @@ subroutine psb_lc_mv_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to_ib - implicit none - + implicit none + class(psb_lcspmat_type), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_ifmt(b,info) call a%free() end if - + end subroutine psb_lc_mv_to_ib subroutine psb_lc_cp_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to_ib - implicit none + implicit none class(psb_lcspmat_type), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -4981,7 +5262,7 @@ subroutine psb_lc_mv_from_i(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from_i - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -4993,20 +5274,20 @@ subroutine psb_lc_mv_from_i(a,b) call a%free() end if call b%free() - + end subroutine psb_lc_mv_from_i - + subroutine psb_lc_cp_from_i(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from_i - implicit none + implicit none class(psb_lcspmat_type), intent(out) :: a class(psb_cspmat_type), intent(in) :: b integer(psb_ipk_) :: info - + if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_ifmt(b%a,info) @@ -5019,12 +5300,12 @@ subroutine psb_lc_mv_to_i(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to_i - implicit none + implicit none class(psb_lcspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_c_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_ifmt(b%a,info) @@ -5032,28 +5313,24 @@ subroutine psb_lc_mv_to_i(a,b) call b%free() end if call a%free() - + end subroutine psb_lc_mv_to_i subroutine psb_lc_cp_to_i(a,b) use psb_error_mod use psb_const_mod use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to_i - implicit none - + implicit none + class(psb_lcspmat_type), intent(in) :: a class(psb_cspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_c_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_ifmt(b%a,info) else call b%free() end if - + end subroutine psb_lc_cp_to_i - - - - diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index 304114869..30cb4d1ed 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == ================================== ! ! @@ -45,7 +45,7 @@ subroutine psb_d_base_cp_to_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -69,7 +69,7 @@ subroutine psb_d_base_cp_from_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -94,7 +94,7 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -103,10 +103,10 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -117,12 +117,12 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -136,7 +136,7 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -148,10 +148,10 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_d_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -160,8 +160,8 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -181,7 +181,7 @@ subroutine psb_d_base_mv_to_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -193,17 +193,17 @@ subroutine psb_d_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -218,7 +218,7 @@ subroutine psb_d_base_mv_from_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -229,17 +229,17 @@ subroutine psb_d_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -255,7 +255,7 @@ subroutine psb_d_base_mv_to_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -267,7 +267,7 @@ subroutine psb_d_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_d_coo_sparse_mat) @@ -285,7 +285,7 @@ subroutine psb_d_base_mv_from_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ subroutine psb_d_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_d_coo_sparse_mat) @@ -313,23 +313,23 @@ end subroutine psb_d_base_mv_from_fmt subroutine psb_d_base_clean_zeros(a, info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_clean_zeros - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_d_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_d_base_clean_zeros -subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_a - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -350,11 +350,11 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_d_base_csput_a -subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_v use psb_d_base_vect_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -366,24 +366,24 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() if (ia%is_dev()) call ia%sync() if (ja%is_dev()) call ja%sync() - call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -395,7 +395,7 @@ end subroutine psb_d_base_csput_v subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csgetrow @@ -433,7 +433,7 @@ end subroutine psb_d_base_csgetrow ! subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csgetblk @@ -456,22 +456,22 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -486,19 +486,19 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'd_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -526,7 +526,7 @@ end subroutine psb_d_base_csgetblk subroutine psb_d_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csclip @@ -547,46 +547,46 @@ subroutine psb_d_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -615,7 +615,7 @@ end subroutine psb_d_base_csclip ! subroutine psb_d_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_tril @@ -627,8 +627,8 @@ subroutine psb_d_base_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_d_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_dpk_), allocatable :: val(:) @@ -640,51 +640,51 @@ subroutine psb_d_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -716,7 +716,7 @@ subroutine psb_d_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -724,8 +724,8 @@ subroutine psb_d_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -738,7 +738,7 @@ subroutine psb_d_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -747,8 +747,8 @@ subroutine psb_d_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -766,7 +766,7 @@ end subroutine psb_d_base_tril subroutine psb_d_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_triu @@ -778,7 +778,7 @@ subroutine psb_d_base_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_d_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) @@ -791,57 +791,57 @@ subroutine psb_d_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -874,13 +874,13 @@ subroutine psb_d_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -888,7 +888,7 @@ subroutine psb_d_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -897,8 +897,8 @@ subroutine psb_d_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -919,45 +919,45 @@ end subroutine psb_d_base_triu subroutine psb_d_base_clone(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_d_base_clone subroutine psb_d_base_make_nonunit(a) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: i, j, m, n, nz, mnm, info - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + integer(psb_ipk_) :: i, j, m, n, nz, mnm, info + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -974,10 +974,10 @@ subroutine psb_d_base_make_nonunit(a) end subroutine psb_d_base_make_nonunit -subroutine psb_d_base_mold(a,b,info) +subroutine psb_d_base_mold(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mold use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -999,7 +999,7 @@ end subroutine psb_d_base_mold subroutine psb_d_base_transp_2mat(a,b) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1019,11 +1019,11 @@ subroutine psb_d_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1035,7 +1035,7 @@ end subroutine psb_d_base_transp_2mat subroutine psb_d_base_transc_2mat(a,b) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transc_2mat - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1055,11 +1055,11 @@ subroutine psb_d_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1071,7 +1071,7 @@ end subroutine psb_d_base_transc_2mat subroutine psb_d_base_transp_1mat(a) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a @@ -1085,12 +1085,12 @@ subroutine psb_d_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1102,7 +1102,7 @@ end subroutine psb_d_base_transp_1mat subroutine psb_d_base_transc_1mat(a) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transc_1mat - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a @@ -1116,12 +1116,12 @@ subroutine psb_d_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1145,11 +1145,11 @@ end subroutine psb_d_base_transc_1mat ! ! == ================================== -subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmm use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1172,10 +1172,10 @@ subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_d_base_csmm -subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csmv use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1199,10 +1199,10 @@ subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_d_base_csmv -subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_cssm use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1225,10 +1225,10 @@ subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) end subroutine psb_d_base_inner_cssm -subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_cssv use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1251,11 +1251,11 @@ subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) end subroutine psb_d_base_inner_cssv -subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cssm use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1271,7 +1271,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1291,42 +1291,42 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) + tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ @@ -1334,21 +1334,21 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(done,x,dzero,tmp,info,trans) - if (info == psb_success_)then + if (info == psb_success_)then do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) + tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if @@ -1357,13 +1357,13 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -1378,11 +1378,11 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_d_base_cssm -subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cssv use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1418,58 +1418,58 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == dzero) then + if (beta == dzero) then call a%inner_spsm(alpha,x,dzero,y,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,y) else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,dzero,tmp,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,tmp) if (info == psb_success_)& & call psb_geaxpby(nar,done,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1479,13 +1479,13 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1500,37 +1500,37 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return contains subroutine inner_vscal(n,d,x,y) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n real(psb_dpk_), intent(in) :: d(*),x(*) real(psb_dpk_), intent(out) :: y(*) integer(psb_ipk_) :: i do i=1,n - y(i) = d(i)*x(i) + y(i) = d(i)*x(i) end do end subroutine inner_vscal subroutine inner_vscal1(n,d,x) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n real(psb_dpk_), intent(in) :: d(*) real(psb_dpk_), intent(inout) :: x(*) integer(psb_ipk_) :: i do i=1,n - x(i) = d(i)*x(i) + x(i) = d(i)*x(i) end do end subroutine inner_vscal1 end subroutine psb_d_base_cssv -subroutine psb_d_base_scals(d,a,info) +subroutine psb_d_base_scals(d,a,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scals use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1550,12 +1550,55 @@ subroutine psb_d_base_scals(d,a,info) end subroutine psb_d_base_scals +subroutine psb_d_base_scalplusidentity(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: acoo -subroutine psb_d_base_scal(d,a,info,side) + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_scalplusidentity + +subroutine psb_d_base_scal(d,a,info,side) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_scal use psb_error_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1581,7 +1624,7 @@ function psb_d_base_maxval(a) result(res) use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_maxval - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1608,27 +1651,27 @@ function psb_d_base_csnmi(a) result(res) use psb_realloc_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csnmi - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1646,27 +1689,27 @@ function psb_d_base_csnm1(a) result(res) use psb_realloc_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csnm1 - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1678,7 +1721,7 @@ function psb_d_base_csnm1(a) result(res) end function psb_d_base_csnm1 -subroutine psb_d_base_rowsum(d,a) +subroutine psb_d_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_rowsum @@ -1700,7 +1743,7 @@ subroutine psb_d_base_rowsum(d,a) end subroutine psb_d_base_rowsum -subroutine psb_d_base_arwsum(d,a) +subroutine psb_d_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_arwsum @@ -1722,7 +1765,7 @@ subroutine psb_d_base_arwsum(d,a) end subroutine psb_d_base_arwsum -subroutine psb_d_base_colsum(d,a) +subroutine psb_d_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_colsum @@ -1744,7 +1787,7 @@ subroutine psb_d_base_colsum(d,a) end subroutine psb_d_base_colsum -subroutine psb_d_base_aclsum(d,a) +subroutine psb_d_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_aclsum @@ -1766,12 +1809,12 @@ subroutine psb_d_base_aclsum(d,a) end subroutine psb_d_base_aclsum -subroutine psb_d_base_get_diag(a,d,info) +subroutine psb_d_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_get_diag - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1791,15 +1834,153 @@ subroutine psb_d_base_get_diag(a,d,info) end subroutine psb_d_base_get_diag +subroutine psb_d_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_spaxpby + + real(psb_dpk_), intent(in) :: alpha + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: beta + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_d_base_spaxpby + +function psb_d_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cmpval + + class(psb_d_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_d_base_cmpval + +function psb_d_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cmpmat + + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_d_base_cmpmat ! == ================================== ! ! ! ! Computational routines for d_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! +! variables. If the actual data type is +! a "normal" one, these are sufficient. +! ! ! ! @@ -1807,11 +1988,11 @@ end subroutine psb_d_base_get_diag -subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_base_vect_mv - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x @@ -1820,7 +2001,7 @@ subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans ! For the time being we just throw everything back - ! onto the normal routines. + ! onto the normal routines. call x%sync() call y%sync() call a%spmm(alpha,x%v,beta,y%v,info,trans) @@ -1832,7 +2013,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_d_base_vect_mod use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x,y @@ -1869,54 +2050,54 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - call x%sync() + call x%sync() call y%sync() - if (present(d)) then + if (present(d)) then call d%sync() - if (present(scale)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(done,d%v(1:nac),x,dzero,info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call tmpv%mlt(done,d%v(1:nac),x,dzero,info) if (info == psb_success_)& & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - if (info == psb_success_) then + if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == dzero) then + if (beta == dzero) then call a%inner_spsm(alpha,x,dzero,y,info,trans) if (info == psb_success_) call y%mlt(d%v(1:nar),info) else allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,dzero,tmpv,info,trans) @@ -1925,7 +2106,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) & call y%axpby(nar,done,tmpv,beta,info) if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1935,13 +2116,13 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1958,12 +2139,12 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_d_base_vect_cssv -subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_inner_vect_sv use psb_error_mod use psb_string_mod use psb_d_base_vect_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x, y @@ -1977,10 +2158,10 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) + call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1988,7 +2169,7 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return @@ -2000,7 +2181,7 @@ subroutine psb_d_base_cp_to_lcoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2009,22 +2190,22 @@ subroutine psb_d_base_cp_to_lcoo(a,b,info) character(len=20) :: name='to_lcoo' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_lcoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2038,7 +2219,7 @@ subroutine psb_d_base_cp_from_lcoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2047,22 +2228,22 @@ subroutine psb_d_base_cp_from_lcoo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_lcoo(b,info) + call tmp%cp_from_lcoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2076,7 +2257,7 @@ subroutine psb_d_base_cp_to_lfmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2086,10 +2267,10 @@ subroutine psb_d_base_cp_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: icoo type(psb_ld_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2102,12 +2283,12 @@ subroutine psb_d_base_cp_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2121,7 +2302,7 @@ subroutine psb_d_base_cp_from_lfmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2133,10 +2314,10 @@ subroutine psb_d_base_cp_from_lfmt(a,b,info) type(psb_ld_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_ld_coo_sparse_mat) call a%cp_from_lcoo(b,info) @@ -2146,8 +2327,8 @@ subroutine psb_d_base_cp_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2166,7 +2347,7 @@ subroutine psb_d_base_mv_to_lcoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2178,17 +2359,17 @@ subroutine psb_d_base_mv_to_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2202,7 +2383,7 @@ subroutine psb_d_base_mv_from_lcoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2213,17 +2394,17 @@ subroutine psb_d_base_mv_from_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2238,7 +2419,7 @@ subroutine psb_d_base_mv_to_lfmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2248,10 +2429,10 @@ subroutine psb_d_base_mv_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: icoo type(psb_ld_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2264,12 +2445,12 @@ subroutine psb_d_base_mv_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2283,7 +2464,7 @@ subroutine psb_d_base_mv_from_lfmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2295,10 +2476,10 @@ subroutine psb_d_base_mv_from_lfmt(a,b,info) type(psb_ld_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_ld_coo_sparse_mat) call a%mv_from_lcoo(b,info) @@ -2308,8 +2489,8 @@ subroutine psb_d_base_mv_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2343,7 +2524,7 @@ subroutine psb_ld_base_cp_to_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2367,7 +2548,7 @@ subroutine psb_ld_base_cp_from_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2392,7 +2573,7 @@ subroutine psb_ld_base_cp_to_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2401,10 +2582,10 @@ subroutine psb_ld_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_ld_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2415,12 +2596,12 @@ subroutine psb_ld_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2434,7 +2615,7 @@ subroutine psb_ld_base_cp_from_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2446,10 +2627,10 @@ subroutine psb_ld_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_ld_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -2458,8 +2639,8 @@ subroutine psb_ld_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2479,7 +2660,7 @@ subroutine psb_ld_base_mv_to_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2491,17 +2672,17 @@ subroutine psb_ld_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2516,7 +2697,7 @@ subroutine psb_ld_base_mv_from_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2527,17 +2708,17 @@ subroutine psb_ld_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2552,7 +2733,7 @@ subroutine psb_ld_base_mv_to_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2564,7 +2745,7 @@ subroutine psb_ld_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_ld_coo_sparse_mat) @@ -2582,7 +2763,7 @@ subroutine psb_ld_base_mv_from_fmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2594,7 +2775,7 @@ subroutine psb_ld_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_ld_coo_sparse_mat) @@ -2610,23 +2791,23 @@ end subroutine psb_ld_base_mv_from_fmt subroutine psb_ld_base_clean_zeros(a, info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clean_zeros - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_ld_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_ld_base_clean_zeros -subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -2647,11 +2828,11 @@ subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_ld_base_csput_a -subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v use psb_d_base_vect_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2664,10 +2845,10 @@ subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() @@ -2677,11 +2858,11 @@ subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2693,7 +2874,7 @@ end subroutine psb_ld_base_csput_v subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetrow @@ -2733,7 +2914,7 @@ end subroutine psb_ld_base_csgetrow ! subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetblk @@ -2757,22 +2938,22 @@ subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -2787,19 +2968,19 @@ subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'ld_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -2827,7 +3008,7 @@ end subroutine psb_ld_base_csgetblk subroutine psb_ld_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csclip @@ -2849,46 +3030,46 @@ subroutine psb_ld_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -2917,7 +3098,7 @@ end subroutine psb_ld_base_csclip ! subroutine psb_ld_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_tril @@ -2929,9 +3110,9 @@ subroutine psb_ld_base_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ld_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_lpk_), allocatable :: ia(:), ja(:) real(psb_dpk_), allocatable :: val(:) @@ -2943,51 +3124,51 @@ subroutine psb_ld_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -3019,7 +3200,7 @@ subroutine psb_ld_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -3027,8 +3208,8 @@ subroutine psb_ld_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -3041,7 +3222,7 @@ subroutine psb_ld_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -3050,8 +3231,8 @@ subroutine psb_ld_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -3069,7 +3250,7 @@ end subroutine psb_ld_base_tril subroutine psb_ld_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_triu @@ -3081,7 +3262,7 @@ subroutine psb_ld_base_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ld_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -3095,57 +3276,57 @@ subroutine psb_ld_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -3178,13 +3359,13 @@ subroutine psb_ld_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -3192,7 +3373,7 @@ subroutine psb_ld_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -3201,8 +3382,8 @@ subroutine psb_ld_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -3223,46 +3404,46 @@ end subroutine psb_ld_base_triu subroutine psb_ld_base_clone(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_ld_base_clone subroutine psb_ld_base_make_nonunit(a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a type(psb_ld_coo_sparse_mat) :: tmp - + integer(psb_ipk_) :: info integer(psb_lpk_) :: i, j, m, n, nz, mnm - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -3279,10 +3460,10 @@ subroutine psb_ld_base_make_nonunit(a) end subroutine psb_ld_base_make_nonunit -subroutine psb_ld_base_mold(a,b,info) +subroutine psb_ld_base_mold(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mold use psb_error_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3304,7 +3485,7 @@ end subroutine psb_ld_base_mold subroutine psb_ld_base_transp_2mat(a,b) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3324,11 +3505,11 @@ subroutine psb_ld_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3340,7 +3521,7 @@ end subroutine psb_ld_base_transp_2mat subroutine psb_ld_base_transc_2mat(a,b) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_2mat - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3360,11 +3541,11 @@ subroutine psb_ld_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3376,7 +3557,7 @@ end subroutine psb_ld_base_transc_2mat subroutine psb_ld_base_transp_1mat(a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a @@ -3390,12 +3571,12 @@ subroutine psb_ld_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3407,7 +3588,7 @@ end subroutine psb_ld_base_transp_1mat subroutine psb_ld_base_transc_1mat(a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_1mat - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a @@ -3421,12 +3602,12 @@ subroutine psb_ld_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3436,10 +3617,10 @@ subroutine psb_ld_base_transc_1mat(a) end subroutine psb_ld_base_transc_1mat -subroutine psb_ld_base_scals(d,a,info) +subroutine psb_ld_base_scals(d,a,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scals use psb_error_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3459,10 +3640,55 @@ subroutine psb_ld_base_scals(d,a,info) end subroutine psb_ld_base_scals -subroutine psb_ld_base_scal(d,a,info,side) +subroutine psb_ld_base_scalplusidentity(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_scalplusidentity + +subroutine psb_ld_base_scal(d,a,info,side) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scal use psb_error_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3488,7 +3714,7 @@ function psb_ld_base_maxval(a) result(res) use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_maxval - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3514,27 +3740,27 @@ function psb_ld_base_csnmi(a) result(res) use psb_realloc_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnmi - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3551,27 +3777,27 @@ function psb_ld_base_csnm1(a) result(res) use psb_realloc_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnm1 - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3582,7 +3808,7 @@ function psb_ld_base_csnm1(a) result(res) end function psb_ld_base_csnm1 -subroutine psb_ld_base_rowsum(d,a) +subroutine psb_ld_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_rowsum @@ -3604,7 +3830,7 @@ subroutine psb_ld_base_rowsum(d,a) end subroutine psb_ld_base_rowsum -subroutine psb_ld_base_arwsum(d,a) +subroutine psb_ld_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_arwsum @@ -3626,7 +3852,7 @@ subroutine psb_ld_base_arwsum(d,a) end subroutine psb_ld_base_arwsum -subroutine psb_ld_base_colsum(d,a) +subroutine psb_ld_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_colsum @@ -3648,7 +3874,7 @@ subroutine psb_ld_base_colsum(d,a) end subroutine psb_ld_base_colsum -subroutine psb_ld_base_aclsum(d,a) +subroutine psb_ld_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_aclsum @@ -3670,12 +3896,151 @@ subroutine psb_ld_base_aclsum(d,a) end subroutine psb_ld_base_aclsum -subroutine psb_ld_base_get_diag(a,d,info) +subroutine psb_ld_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_spaxpby + + real(psb_dpk_), intent(in) :: alpha + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: beta + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ld_base_spaxpby + +function psb_ld_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cmpval + + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ld_base_cmpval + +function psb_ld_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cmpmat + + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ld_base_cmpmat + +subroutine psb_ld_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_get_diag - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3701,7 +4066,7 @@ subroutine psb_ld_base_cp_to_icoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3710,22 +4075,22 @@ subroutine psb_ld_base_cp_to_icoo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. type(psb_ld_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3739,7 +4104,7 @@ subroutine psb_ld_base_cp_from_icoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3748,22 +4113,22 @@ subroutine psb_ld_base_cp_from_icoo(a,b,info) character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. type(psb_ld_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_icoo(b,info) + call tmp%cp_from_icoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3778,7 +4143,7 @@ subroutine psb_ld_base_cp_to_ifmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3788,10 +4153,10 @@ subroutine psb_ld_base_cp_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: icoo type(psb_ld_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3804,12 +4169,12 @@ subroutine psb_ld_base_cp_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3823,7 +4188,7 @@ subroutine psb_ld_base_cp_from_ifmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3835,10 +4200,10 @@ subroutine psb_ld_base_cp_from_ifmt(a,b,info) type(psb_ld_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_d_coo_sparse_mat) call a%cp_from_icoo(b,info) @@ -3848,8 +4213,8 @@ subroutine psb_ld_base_cp_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -3868,7 +4233,7 @@ subroutine psb_ld_base_mv_to_icoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3880,17 +4245,17 @@ subroutine psb_ld_base_mv_to_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -3905,7 +4270,7 @@ subroutine psb_ld_base_mv_from_icoo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3916,17 +4281,17 @@ subroutine psb_ld_base_mv_from_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -3942,7 +4307,7 @@ subroutine psb_ld_base_mv_to_ifmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3952,10 +4317,10 @@ subroutine psb_ld_base_mv_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: icoo type(psb_ld_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3968,12 +4333,12 @@ subroutine psb_ld_base_mv_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3987,7 +4352,7 @@ subroutine psb_ld_base_mv_from_ifmt(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ld_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3999,10 +4364,10 @@ subroutine psb_ld_base_mv_from_ifmt(a,b,info) type(psb_ld_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_d_coo_sparse_mat) call a%mv_from_icoo(b,info) @@ -4012,8 +4377,8 @@ subroutine psb_ld_base_mv_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -4026,5 +4391,3 @@ subroutine psb_ld_base_mv_from_ifmt(a,b,info) return end subroutine psb_ld_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_d_coo_impl.F90 b/base/serial/impl/psb_d_coo_impl.F90 index de04a1360..cd5ea5a80 100644 --- a/base/serial/impl/psb_d_coo_impl.F90 +++ b/base/serial/impl/psb_d_coo_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! -subroutine psb_d_coo_get_diag(a,d,info) +! +! +subroutine psb_d_coo_get_diag(a,d,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -47,19 +47,19 @@ subroutine psb_d_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = done + if (a%is_unit()) then + d(1:mnm) = done else d(1:mnm) = dzero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -74,12 +74,12 @@ subroutine psb_d_coo_get_diag(a,d,info) end subroutine psb_d_coo_get_diag -subroutine psb_d_coo_scal(d,a,info,side) +subroutine psb_d_coo_scal(d,a,info,side) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -88,44 +88,44 @@ subroutine psb_d_coo_scal(d,a,info,side) integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -143,11 +143,11 @@ subroutine psb_d_coo_scal(d,a,info,side) end subroutine psb_d_coo_scal -subroutine psb_d_coo_scals(d,a,info) +subroutine psb_d_coo_scals(d,a,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -160,13 +160,14 @@ subroutine psb_d_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if do i=1,a%get_nzeros() a%val(i) = a%val(i) * d enddo + call a%set_host() call psb_erractionrestore(err_act) @@ -178,12 +179,207 @@ subroutine psb_d_coo_scals(d,a,info) end subroutine psb_d_coo_scals +subroutine psb_d_coo_scalplusidentity(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info -subroutine psb_d_coo_reallocate_nz(nz,a) + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + done + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_coo_scalplusidentity + +subroutine psb_d_coo_spaxpby(alpha,a,beta,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_coo_spaxpby' + type(psb_d_coo_sparse_mat) :: tcoo,bcoo + integer(psb_ipk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_d_coo_spaxpby + +function psb_d_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cmpval + + class(psb_d_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_d_coo_cmpval + +function psb_d_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cmpmat + + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_ipk_) :: nza, nzb, nzl, M, N + type(psb_d_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-done)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_d_coo_cmpmat + +subroutine psb_d_coo_reallocate_nz(nz,a) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -197,7 +393,7 @@ subroutine psb_d_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -211,11 +407,11 @@ subroutine psb_d_coo_reallocate_nz(nz,a) end subroutine psb_d_coo_reallocate_nz -subroutine psb_d_coo_ensure_size(nz,a) +subroutine psb_d_coo_ensure_size(nz,a) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -229,7 +425,7 @@ subroutine psb_d_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -243,10 +439,10 @@ subroutine psb_d_coo_ensure_size(nz,a) end subroutine psb_d_coo_ensure_size -subroutine psb_d_coo_mold(a,b,info) +subroutine psb_d_coo_mold(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mold use psb_error_mod - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -255,16 +451,16 @@ subroutine psb_d_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_d_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -279,9 +475,9 @@ end subroutine psb_d_coo_mold subroutine psb_d_coo_reinit(a,clear) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -293,17 +489,17 @@ subroutine psb_d_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = dzero call a%set_host() call a%set_upd() @@ -328,7 +524,7 @@ subroutine psb_d_coo_trim(a) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' @@ -342,7 +538,7 @@ subroutine psb_d_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -355,13 +551,13 @@ end subroutine psb_d_coo_trim subroutine psb_d_coo_clean_zeros(a, info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_clean_zeros - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -372,14 +568,14 @@ subroutine psb_d_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_d_coo_clean_zeros subroutine psb_d_coo_clean_negidx(a,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_clean_negidx - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -387,13 +583,13 @@ subroutine psb_d_coo_clean_negidx(a,info) integer(psb_ipk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_d_coo_clean_negidx -subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_clean_negidx_inner - implicit none + implicit none integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) @@ -402,24 +598,24 @@ subroutine psb_d_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_ipk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_d_coo_clean_negidx_inner -subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -429,22 +625,22 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -452,7 +648,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(izero) @@ -464,7 +660,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -479,10 +675,10 @@ end subroutine psb_d_coo_allocate_mnnz subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -490,12 +686,12 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -504,26 +700,26 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -538,7 +734,7 @@ end subroutine psb_d_coo_print function psb_d_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_nz_row + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_nz_row implicit none class(psb_d_coo_sparse_mat), intent(in) :: a @@ -547,39 +743,39 @@ function psb_d_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -587,12 +783,12 @@ function psb_d_coo_get_nz_row(idx,a) result(res) end function psb_d_coo_get_nz_row -subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cssm - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -611,14 +807,14 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif if (a%is_dev()) call a%sync() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -643,7 +839,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() if (alpha == dzero) then @@ -659,15 +855,15 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == dzero) then + if (beta == dzero) then call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & m,nc,nnz,a%ia,a%ja,a%val,& & x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -697,11 +893,11 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none + & ia,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) real(psb_dpk_), intent(in) :: val(*), x(ldx,*) @@ -719,7 +915,7 @@ contains end if - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if @@ -727,14 +923,14 @@ contains nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = dzero - do + do if (j > nnz) exit if (ia(j) > i) exit acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) @@ -742,14 +938,14 @@ contains end do y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc(1:nc) = dzero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j + 1 exit @@ -760,12 +956,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = dzero - do + do i=nr, 1, -1 + acc(1:nc) = dzero + do if (j < 1) exit if (ia(j) < i) exit acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) @@ -774,15 +970,15 @@ contains y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = dzero - do + do i=nr, 1, -1 + acc(1:nc) = dzero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j - 1 exit @@ -795,68 +991,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do @@ -864,68 +1060,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / (val(j)) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / (val(j)) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) j = j + 1 end do end do @@ -940,12 +1136,12 @@ end subroutine psb_d_coo_cssm -subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cssv - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -969,7 +1165,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -989,7 +1185,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1009,20 +1205,20 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) return end if - if (beta == dzero) then + if (beta == dzero) then call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if do i = 1, m y(i) = alpha*y(i) end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 @@ -1031,7 +1227,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -1047,11 +1243,11 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none + & ia,ja,val,x,y,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nz,ia(*),ja(*) real(psb_dpk_), intent(in) :: val(*), x(*) @@ -1062,21 +1258,21 @@ contains real(psb_dpk_) :: acc info = psb_success_ - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc = dzero - do + do if (j > nnz) exit if (ia(j) > i) exit acc = acc + val(j)*y(ja(j)) @@ -1084,14 +1280,14 @@ contains end do y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc = dzero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j + 1 exit @@ -1102,12 +1298,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc = dzero - do + do i=nr, 1, -1 + acc = dzero + do if (j < 1) exit if (ia(j) < i) exit acc = acc + val(j)*y(ja(j)) @@ -1116,15 +1312,15 @@ contains y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc = dzero - do + do i=nr, 1, -1 + acc = dzero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j - 1 exit @@ -1137,68 +1333,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 + y(jc) = y(jc) - val(j)*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do @@ -1206,68 +1402,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j - 1 + y(jc) = y(jc) - (val(j))*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /(val(j)) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc + y(jc) = y(jc) - (val(j))*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc + y(jc) = y(jc) - (val(j))*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /(val(j)) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc + y(jc) = y(jc) - (val(j))*acc j = j + 1 end do end do @@ -1281,12 +1477,12 @@ contains end subroutine psb_d_coo_cssv -subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csmv - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -1305,7 +1501,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1323,7 +1519,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1354,8 +1550,8 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == dzero) then do i = 1, min(m,n) y(i) = alpha*x(i) @@ -1364,7 +1560,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) y(i) = dzero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i) = beta*y(i) + alpha*x(i) end do do i = min(m,n)+1, m @@ -1386,28 +1582,28 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) end if - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = dzero - do - if (i>nnz) then + do + if (i>nnz) then y(ir) = y(ir) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir) = y(ir) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = dzero endif acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == done) then i = 1 @@ -1425,7 +1621,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - a%val(i)*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1435,7 +1631,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) end if !.....end testing on alpha - else if (ctra) then + else if (ctra) then if (alpha == done) then i = 1 @@ -1453,7 +1649,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - (a%val(i))*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1475,12 +1671,12 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_d_coo_csmv -subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csmm - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1499,7 +1695,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1518,7 +1714,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1558,8 +1754,8 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == dzero) then do i = 1, min(m,n) y(i,1:nc) = alpha*x(i,1:nc) @@ -1568,7 +1764,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) y(i,1:nc) = dzero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) end do do i = min(m,n)+1, m @@ -1590,28 +1786,28 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) end if - if (.not.tra) then + if (.not.tra) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = dzero - do - if (i>nnz) then + do + if (i>nnz) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = dzero endif acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == done) then i = 1 @@ -1629,7 +1825,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1657,7 +1853,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - (a%val(i))*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1681,7 +1877,7 @@ end subroutine psb_d_coo_csmm function psb_d_coo_maxval(a) result(res) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_maxval - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1691,13 +1887,13 @@ function psb_d_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1707,7 +1903,7 @@ end function psb_d_coo_maxval function psb_d_coo_csnmi(a) result(res) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csnmi - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1724,15 +1920,15 @@ function psb_d_coo_csnmi(a) result(res) res = dzero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = dzero - do while (i<=nnz) + res = dzero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -1747,7 +1943,7 @@ function psb_d_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = done else vt = dzero @@ -1759,7 +1955,7 @@ function psb_d_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_d_coo_csnmi @@ -1768,7 +1964,7 @@ function psb_d_coo_csnm1(a) result(res) use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csnm1 - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1787,7 +1983,7 @@ function psb_d_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = done else vt = dzero @@ -1803,7 +1999,7 @@ function psb_d_coo_csnm1(a) result(res) end function psb_d_coo_csnm1 -subroutine psb_d_coo_rowsum(d,a) +subroutine psb_d_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_rowsum @@ -1823,13 +2019,13 @@ subroutine psb_d_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1843,7 +2039,7 @@ subroutine psb_d_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1851,7 +2047,7 @@ subroutine psb_d_coo_rowsum(d,a) end subroutine psb_d_coo_rowsum -subroutine psb_d_coo_arwsum(d,a) +subroutine psb_d_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_arwsum @@ -1870,13 +2066,13 @@ subroutine psb_d_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1889,7 +2085,7 @@ subroutine psb_d_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1897,7 +2093,7 @@ subroutine psb_d_coo_arwsum(d,a) end subroutine psb_d_coo_arwsum -subroutine psb_d_coo_colsum(d,a) +subroutine psb_d_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_colsum @@ -1916,13 +2112,13 @@ subroutine psb_d_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1936,7 +2132,7 @@ subroutine psb_d_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1944,7 +2140,7 @@ subroutine psb_d_coo_colsum(d,a) end subroutine psb_d_coo_colsum -subroutine psb_d_coo_aclsum(d,a) +subroutine psb_d_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_aclsum @@ -1963,14 +2159,14 @@ subroutine psb_d_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1981,10 +2177,10 @@ subroutine psb_d_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -2009,7 +2205,7 @@ end subroutine psb_d_coo_aclsum subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2026,7 +2222,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2054,22 +2250,22 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2078,12 +2274,12 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2127,19 +2323,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2154,13 +2350,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2178,31 +2374,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -2211,7 +2407,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -2219,8 +2415,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -2233,12 +2429,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2250,11 +2446,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2268,7 +2464,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -2277,12 +2473,12 @@ end subroutine psb_d_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2327,27 +2523,27 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2356,12 +2552,12 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2409,19 +2605,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2436,13 +2632,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2460,34 +2656,34 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -2495,10 +2691,10 @@ contains end if enddo call psb_d_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -2507,7 +2703,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -2516,27 +2712,27 @@ contains nrd = max(a%get_nrows(),1) nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then - k = 0 + + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - end if + end if end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -2544,14 +2740,14 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) @@ -2573,12 +2769,12 @@ contains end subroutine psb_d_coo_csgetrow -subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput_a - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -2590,30 +2786,30 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) character(len=20) :: name='d_coo_csput_a_impl' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -2624,13 +2820,13 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -2641,22 +2837,22 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call d_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2677,7 +2873,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: ia(:),ja(:) @@ -2688,11 +2884,11 @@ contains integer(psb_ipk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -2708,7 +2904,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2726,13 +2922,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2744,18 +2940,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2767,7 +2963,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2781,18 +2977,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2804,7 +3000,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2826,10 +3022,10 @@ contains end subroutine psb_d_coo_csput_a -subroutine psb_d_cp_coo_to_coo(a,b,info) +subroutine psb_d_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_coo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2868,10 +3064,10 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) end subroutine psb_d_cp_coo_to_coo -subroutine psb_d_cp_coo_from_coo(a,b,info) +subroutine psb_d_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_coo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2914,10 +3110,10 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) end subroutine psb_d_cp_coo_from_coo -subroutine psb_d_cp_coo_to_fmt(a,b,info) +subroutine psb_d_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_fmt - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2946,10 +3142,10 @@ subroutine psb_d_cp_coo_to_fmt(a,b,info) end subroutine psb_d_cp_coo_to_fmt -subroutine psb_d_cp_coo_from_fmt(a,b,info) +subroutine psb_d_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_fmt - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2980,10 +3176,10 @@ subroutine psb_d_cp_coo_from_fmt(a,b,info) end subroutine psb_d_cp_coo_from_fmt -subroutine psb_d_mv_coo_to_coo(a,b,info) +subroutine psb_d_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_to_coo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3022,10 +3218,10 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) end subroutine psb_d_mv_coo_to_coo -subroutine psb_d_mv_coo_from_coo(a,b,info) +subroutine psb_d_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_from_coo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3066,10 +3262,10 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) end subroutine psb_d_mv_coo_from_coo -subroutine psb_d_mv_coo_to_fmt(a,b,info) +subroutine psb_d_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_to_fmt - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3098,10 +3294,10 @@ subroutine psb_d_mv_coo_to_fmt(a,b,info) end subroutine psb_d_mv_coo_to_fmt -subroutine psb_d_mv_coo_from_fmt(a,b,info) +subroutine psb_d_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_mv_coo_from_fmt - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3134,7 +3330,7 @@ end subroutine psb_d_mv_coo_from_fmt subroutine psb_d_coo_cp_from(a,b) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_cp_from - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat), intent(in) :: b @@ -3164,7 +3360,7 @@ end subroutine psb_d_coo_cp_from subroutine psb_d_coo_mv_from(a,b) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mv_from - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat), intent(inout) :: b @@ -3193,11 +3389,11 @@ end subroutine psb_d_coo_mv_from -subroutine psb_d_fix_coo(a,info,idir) +subroutine psb_d_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3218,17 +3414,17 @@ subroutine psb_d_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_d_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -3251,14 +3447,14 @@ end subroutine psb_d_fix_coo -subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) @@ -3283,14 +3479,14 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -3299,17 +3495,17 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - select case(idir_) - case(psb_row_major_) + select case(idir_) + + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -3319,15 +3515,15 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -3338,9 +3534,9 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -3348,7 +3544,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3358,87 +3554,87 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3450,7 +3646,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -3459,7 +3655,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3469,73 +3665,73 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3544,15 +3740,15 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. - ! + ! let's try in place. + ! call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) @@ -3580,52 +3776,52 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3638,7 +3834,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -3648,13 +3844,13 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -3668,10 +3864,10 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -3679,7 +3875,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3689,86 +3885,86 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3780,7 +3976,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -3788,7 +3984,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3797,73 +3993,73 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3874,7 +4070,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & @@ -3902,42 +4098,42 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -3945,8 +4141,8 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3965,7 +4161,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -3979,10 +4175,10 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_d_fix_coo_inner -subroutine psb_d_cp_coo_to_lcoo(a,b,info) +subroutine psb_d_cp_coo_to_lcoo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_lcoo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4022,10 +4218,10 @@ subroutine psb_d_cp_coo_to_lcoo(a,b,info) end subroutine psb_d_cp_coo_to_lcoo -subroutine psb_d_cp_coo_from_lcoo(a,b,info) +subroutine psb_d_cp_coo_from_lcoo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_lcoo - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -4073,11 +4269,11 @@ end subroutine psb_d_cp_coo_from_lcoo ! ! -subroutine psb_ld_coo_get_diag(a,d,info) +subroutine psb_ld_coo_get_diag(a,d,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4092,19 +4288,19 @@ subroutine psb_ld_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = done + if (a%is_unit()) then + d(1:mnm) = done else d(1:mnm) = dzero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -4118,12 +4314,12 @@ subroutine psb_ld_coo_get_diag(a,d,info) end subroutine psb_ld_coo_get_diag -subroutine psb_ld_coo_scal(d,a,info,side) +subroutine psb_ld_coo_scal(d,a,info,side) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4133,44 +4329,44 @@ subroutine psb_ld_coo_scal(d,a,info,side) integer(psb_lpk_) :: mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -4188,11 +4384,11 @@ subroutine psb_ld_coo_scal(d,a,info,side) end subroutine psb_ld_coo_scal -subroutine psb_ld_coo_scals(d,a,info) +subroutine psb_ld_coo_scals(d,a,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4206,7 +4402,7 @@ subroutine psb_ld_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -4228,7 +4424,7 @@ end subroutine psb_ld_coo_scals function psb_ld_coo_maxval(a) result(res) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_maxval - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -4238,13 +4434,13 @@ function psb_ld_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -4254,7 +4450,7 @@ end function psb_ld_coo_maxval function psb_ld_coo_csnmi(a) result(res) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnmi - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -4271,15 +4467,15 @@ function psb_ld_coo_csnmi(a) result(res) res = dzero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = dzero - do while (i<=nnz) + res = dzero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -4294,7 +4490,7 @@ function psb_ld_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = done else vt = dzero @@ -4306,7 +4502,7 @@ function psb_ld_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_ld_coo_csnmi @@ -4315,7 +4511,7 @@ function psb_ld_coo_csnm1(a) result(res) use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnm1 - implicit none + implicit none class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -4334,7 +4530,7 @@ function psb_ld_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = done else vt = dzero @@ -4350,7 +4546,7 @@ function psb_ld_coo_csnm1(a) result(res) end function psb_ld_coo_csnm1 -subroutine psb_ld_coo_rowsum(d,a) +subroutine psb_ld_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_rowsum @@ -4371,13 +4567,13 @@ subroutine psb_ld_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -4391,7 +4587,7 @@ subroutine psb_ld_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4399,7 +4595,7 @@ subroutine psb_ld_coo_rowsum(d,a) end subroutine psb_ld_coo_rowsum -subroutine psb_ld_coo_arwsum(d,a) +subroutine psb_ld_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_arwsum @@ -4419,13 +4615,13 @@ subroutine psb_ld_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -4438,7 +4634,7 @@ subroutine psb_ld_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4446,7 +4642,7 @@ subroutine psb_ld_coo_arwsum(d,a) end subroutine psb_ld_coo_arwsum -subroutine psb_ld_coo_colsum(d,a) +subroutine psb_ld_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_colsum @@ -4466,13 +4662,13 @@ subroutine psb_ld_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -4486,7 +4682,7 @@ subroutine psb_ld_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4494,7 +4690,7 @@ subroutine psb_ld_coo_colsum(d,a) end subroutine psb_ld_coo_colsum -subroutine psb_ld_coo_aclsum(d,a) +subroutine psb_ld_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_aclsum @@ -4514,14 +4710,14 @@ subroutine psb_ld_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -4532,10 +4728,10 @@ subroutine psb_ld_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4543,11 +4739,207 @@ subroutine psb_ld_coo_aclsum(d,a) end subroutine psb_ld_coo_aclsum -subroutine psb_ld_coo_reallocate_nz(nz,a) +subroutine psb_ld_coo_scalplusidentity(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + done + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_scalplusidentity + +subroutine psb_ld_coo_spaxpby(alpha,a,beta,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: alpha + real(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_spaxpby' + type(psb_ld_coo_sparse_mat) :: tcoo,bcoo + integer(psb_lpk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ld_coo_spaxpby + +function psb_ld_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cmpval + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ld_coo_cmpval + +function psb_ld_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cmpmat + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_lpk_) :: nza, nzb, nzl, M, N + type(psb_ld_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-1_psb_dpk_)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ld_coo_cmpmat + +subroutine psb_ld_coo_reallocate_nz(nz,a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4562,7 +4954,7 @@ subroutine psb_ld_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4576,11 +4968,11 @@ subroutine psb_ld_coo_reallocate_nz(nz,a) end subroutine psb_ld_coo_reallocate_nz -subroutine psb_ld_coo_ensure_size(nz,a) +subroutine psb_ld_coo_ensure_size(nz,a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -4594,7 +4986,7 @@ subroutine psb_ld_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4608,10 +5000,10 @@ subroutine psb_ld_coo_ensure_size(nz,a) end subroutine psb_ld_coo_ensure_size -subroutine psb_ld_coo_mold(a,b,info) +subroutine psb_ld_coo_mold(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mold use psb_error_mod - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4620,16 +5012,16 @@ subroutine psb_ld_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_ld_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4644,9 +5036,9 @@ end subroutine psb_ld_coo_mold subroutine psb_ld_coo_reinit(a,clear) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4658,17 +5050,17 @@ subroutine psb_ld_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = dzero call a%set_host() call a%set_upd() @@ -4693,7 +5085,7 @@ subroutine psb_ld_coo_trim(a) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info integer(psb_lpk_) :: nz @@ -4708,7 +5100,7 @@ subroutine psb_ld_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4721,13 +5113,13 @@ end subroutine psb_ld_coo_trim subroutine psb_ld_coo_clean_zeros(a, info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_zeros - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -4738,14 +5130,14 @@ subroutine psb_ld_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_ld_coo_clean_zeros subroutine psb_ld_coo_clean_negidx(a,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_negidx - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -4753,14 +5145,14 @@ subroutine psb_ld_coo_clean_negidx(a,info) integer(psb_lpk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_ld_coo_clean_negidx -#if defined(IPK4) && defined(LPK8) -subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +#if defined(IPK4) && defined(LPK8) +subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_negidx_inner - implicit none + implicit none integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) @@ -4769,25 +5161,25 @@ subroutine psb_ld_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_lpk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_ld_coo_clean_negidx_inner #endif -subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4798,22 +5190,22 @@ subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -4821,7 +5213,7 @@ subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(lzero) @@ -4833,7 +5225,7 @@ subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4848,10 +5240,10 @@ end subroutine psb_ld_coo_allocate_mnnz subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4864,8 +5256,8 @@ subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_lpk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4874,26 +5266,26 @@ subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -4908,7 +5300,7 @@ end subroutine psb_ld_coo_print function psb_ld_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_nz_row + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_nz_row implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a @@ -4918,40 +5310,40 @@ function psb_ld_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: inza if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. inza = nza ip = psb_bsrch(idx,inza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -4975,7 +5367,7 @@ end function psb_ld_coo_get_nz_row subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4992,7 +5384,7 @@ subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5021,22 +5413,22 @@ subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5045,12 +5437,12 @@ subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5095,19 +5487,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5122,13 +5514,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5146,31 +5538,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -5179,7 +5571,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -5187,8 +5579,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -5201,12 +5593,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5218,11 +5610,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5236,7 +5628,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -5245,12 +5637,12 @@ end subroutine psb_ld_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -5268,7 +5660,7 @@ subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5296,22 +5688,22 @@ subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5320,12 +5712,12 @@ subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5374,19 +5766,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5401,13 +5793,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5425,32 +5817,32 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -5458,10 +5850,10 @@ contains end if enddo call psb_ld_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -5470,7 +5862,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -5484,12 +5876,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5503,11 +5895,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5531,12 +5923,12 @@ contains end subroutine psb_ld_coo_csgetrow -subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csput_a - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -5549,30 +5941,30 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) logical, parameter :: debug=.false. integer(psb_lpk_) :: nza, i,j,k, nzl, isza integer(psb_ipk_) :: debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -5583,13 +5975,13 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -5600,22 +5992,22 @@ subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call ld_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -5636,7 +6028,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: ia(:),ja(:) @@ -5647,11 +6039,11 @@ contains integer(psb_lpk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -5667,7 +6059,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -5685,13 +6077,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() innz = nnz @@ -5702,18 +6094,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5725,7 +6117,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -5739,18 +6131,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5762,7 +6154,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -5784,10 +6176,10 @@ contains end subroutine psb_ld_coo_csput_a -subroutine psb_ld_cp_coo_to_coo(a,b,info) +subroutine psb_ld_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_coo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5827,10 +6219,10 @@ subroutine psb_ld_cp_coo_to_coo(a,b,info) end subroutine psb_ld_cp_coo_to_coo -subroutine psb_ld_cp_coo_from_coo(a,b,info) +subroutine psb_ld_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_coo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5873,10 +6265,10 @@ subroutine psb_ld_cp_coo_from_coo(a,b,info) end subroutine psb_ld_cp_coo_from_coo -subroutine psb_ld_cp_coo_to_fmt(a,b,info) +subroutine psb_ld_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_fmt - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5905,10 +6297,10 @@ subroutine psb_ld_cp_coo_to_fmt(a,b,info) end subroutine psb_ld_cp_coo_to_fmt -subroutine psb_ld_cp_coo_from_fmt(a,b,info) +subroutine psb_ld_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_fmt - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5939,10 +6331,10 @@ subroutine psb_ld_cp_coo_from_fmt(a,b,info) end subroutine psb_ld_cp_coo_from_fmt -subroutine psb_ld_mv_coo_to_coo(a,b,info) +subroutine psb_ld_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_coo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5981,10 +6373,10 @@ subroutine psb_ld_mv_coo_to_coo(a,b,info) end subroutine psb_ld_mv_coo_to_coo -subroutine psb_ld_mv_coo_from_coo(a,b,info) +subroutine psb_ld_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_coo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6025,10 +6417,10 @@ subroutine psb_ld_mv_coo_from_coo(a,b,info) end subroutine psb_ld_mv_coo_from_coo -subroutine psb_ld_mv_coo_to_fmt(a,b,info) +subroutine psb_ld_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_fmt - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6057,10 +6449,10 @@ subroutine psb_ld_mv_coo_to_fmt(a,b,info) end subroutine psb_ld_mv_coo_to_fmt -subroutine psb_ld_mv_coo_from_fmt(a,b,info) +subroutine psb_ld_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_fmt - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6093,7 +6485,7 @@ end subroutine psb_ld_mv_coo_from_fmt subroutine psb_ld_coo_cp_from(a,b) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cp_from - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a type(psb_ld_coo_sparse_mat), intent(in) :: b @@ -6123,7 +6515,7 @@ end subroutine psb_ld_coo_cp_from subroutine psb_ld_coo_mv_from(a,b) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mv_from - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a type(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -6152,11 +6544,11 @@ end subroutine psb_ld_coo_mv_from -subroutine psb_ld_fix_coo(a,info,idir) +subroutine psb_ld_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -6177,17 +6569,17 @@ subroutine psb_ld_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_ld_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -6210,14 +6602,14 @@ end subroutine psb_ld_fix_coo -subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -6244,14 +6636,14 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -6260,16 +6652,16 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - select case(idir_) + select case(idir_) - case(psb_row_major_) + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -6277,17 +6669,17 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = (info == 0) else use_buffers = .false. - end if - - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + end if + + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -6298,9 +6690,9 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -6308,7 +6700,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6318,87 +6710,87 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6410,7 +6802,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -6419,7 +6811,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6429,73 +6821,73 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6504,14 +6896,14 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. + ! let's try in place. ! inzin = nzin call psi_msort_up(inzin,ia(1:),iaux(1:),iret) @@ -6541,52 +6933,52 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6599,7 +6991,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -6609,13 +7001,13 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -6629,10 +7021,10 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -6640,7 +7032,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6650,86 +7042,86 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6741,7 +7133,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -6749,7 +7141,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6758,73 +7150,73 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6835,7 +7227,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then inzin = nzin call psi_msort_up(inzin,ja(1:),iaux(1:),iret) @@ -6864,42 +7256,42 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -6907,8 +7299,8 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6927,7 +7319,7 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -6941,10 +7333,10 @@ subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_ld_fix_coo_inner -subroutine psb_ld_cp_coo_to_icoo(a,b,info) +subroutine psb_ld_cp_coo_to_icoo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_icoo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6984,10 +7376,10 @@ subroutine psb_ld_cp_coo_to_icoo(a,b,info) end subroutine psb_ld_cp_coo_to_icoo -subroutine psb_ld_cp_coo_from_icoo(a,b,info) +subroutine psb_ld_cp_coo_from_icoo(a,b,info) use psb_error_mod use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_icoo - implicit none + implicit none class(psb_ld_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -7027,4 +7419,3 @@ subroutine psb_ld_cp_coo_from_icoo(a,b,info) return end subroutine psb_ld_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index 63dabf1ec..eb1f2021b 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csmv - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -72,7 +72,7 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -81,7 +81,7 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) if (a%is_dev()) call a%sync() - if (size(x,1) psb_d_csc_csmm - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -350,13 +350,13 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) end if tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -364,16 +364,16 @@ subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_d_csc_cssv - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -632,7 +632,7 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -642,28 +642,28 @@ subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x,1) psb_d_csc_cssm - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -852,7 +852,7 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -862,23 +862,23 @@ subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (size(x,1) psb_d_csc_maxval - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1066,7 +1066,7 @@ function psb_d_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero @@ -1074,7 +1074,7 @@ function psb_d_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1085,7 +1085,7 @@ function psb_d_csc_csnm1(a) result(res) use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csnm1 - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1099,13 +1099,13 @@ function psb_d_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = dzero + res = dzero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -1115,12 +1115,12 @@ function psb_d_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_d_csc_csnm1 -subroutine psb_d_csc_colsum(d,a) +subroutine psb_d_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_colsum @@ -1140,7 +1140,7 @@ subroutine psb_d_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1148,19 +1148,19 @@ subroutine psb_d_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = done else d(i) = dzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1168,7 +1168,7 @@ subroutine psb_d_csc_colsum(d,a) end subroutine psb_d_csc_colsum -subroutine psb_d_csc_aclsum(d,a) +subroutine psb_d_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_aclsum @@ -1188,7 +1188,7 @@ subroutine psb_d_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1197,25 +1197,25 @@ subroutine psb_d_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = done else d(i) = dzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1223,7 +1223,7 @@ subroutine psb_d_csc_aclsum(d,a) end subroutine psb_d_csc_aclsum -subroutine psb_d_csc_rowsum(d,a) +subroutine psb_d_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_rowsum @@ -1244,14 +1244,14 @@ subroutine psb_d_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1265,7 +1265,7 @@ subroutine psb_d_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1273,7 +1273,7 @@ subroutine psb_d_csc_rowsum(d,a) end subroutine psb_d_csc_rowsum -subroutine psb_d_csc_arwsum(d,a) +subroutine psb_d_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_arwsum @@ -1294,14 +1294,14 @@ subroutine psb_d_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1315,7 +1315,7 @@ subroutine psb_d_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1324,11 +1324,11 @@ subroutine psb_d_csc_arwsum(d,a) end subroutine psb_d_csc_arwsum -subroutine psb_d_csc_get_diag(a,d,info) +subroutine psb_d_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_get_diag - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1343,28 +1343,28 @@ subroutine psb_d_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = done + if (a%is_unit()) then + d(1:mnm) = done else do i=1, mnm d(i) = dzero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = dzero end do call psb_erractionrestore(err_act) @@ -1377,12 +1377,12 @@ subroutine psb_d_csc_get_diag(a,d,info) end subroutine psb_d_csc_get_diag -subroutine psb_d_csc_scal(d,a,info,side) +subroutine psb_d_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scal use psb_string_mod - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1393,7 +1393,7 @@ subroutine psb_d_csc_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -1401,39 +1401,39 @@ subroutine psb_d_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -1449,11 +1449,11 @@ subroutine psb_d_csc_scal(d,a,info,side) end subroutine psb_d_csc_scal -subroutine psb_d_csc_scals(d,a,info) +subroutine psb_d_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_scals - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1467,7 +1467,7 @@ subroutine psb_d_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1486,7 +1486,7 @@ subroutine psb_d_csc_scals(d,a,info) end subroutine psb_d_csc_scals -! == =================================== +! == =================================== ! ! ! @@ -1496,11 +1496,11 @@ end subroutine psb_d_csc_scals ! ! ! -! == =================================== +! == =================================== subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1518,7 +1518,7 @@ subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1547,35 +1547,35 @@ subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1621,12 +1621,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1637,19 +1637,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1663,9 +1663,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1677,9 +1677,9 @@ contains enddo end do end if - + end subroutine csc_getptn - + end subroutine psb_d_csc_csgetptn @@ -1687,7 +1687,7 @@ end subroutine psb_d_csc_csgetptn subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1706,7 +1706,7 @@ subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1716,7 +1716,7 @@ subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1736,22 +1736,22 @@ subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -1759,13 +1759,13 @@ subroutine psb_d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1813,12 +1813,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1829,7 +1829,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -1837,12 +1837,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1858,9 +1858,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1880,11 +1880,11 @@ end subroutine psb_d_csc_csgetrow -subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput_a - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -1903,26 +1903,26 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -1933,25 +1933,25 @@ subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_d_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -1977,7 +1977,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -1995,13 +1995,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -2011,19 +2011,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2036,18 +2036,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2070,12 +2070,12 @@ end subroutine psb_d_csc_csput_a -subroutine psb_d_cp_csc_from_coo(a,b,info) +subroutine psb_d_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_from_coo - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b @@ -2098,11 +2098,11 @@ end subroutine psb_d_cp_csc_from_coo -subroutine psb_d_cp_csc_to_coo(a,b,info) +subroutine psb_d_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_to_coo - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b @@ -2132,7 +2132,7 @@ subroutine psb_d_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -2140,12 +2140,12 @@ subroutine psb_d_cp_csc_to_coo(a,b,info) end subroutine psb_d_cp_csc_to_coo -subroutine psb_d_mv_csc_to_coo(a,b,info) +subroutine psb_d_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_to_coo - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b @@ -2183,13 +2183,13 @@ end subroutine psb_d_mv_csc_to_coo -subroutine psb_d_mv_csc_from_coo(a,b,info) +subroutine psb_d_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_coo - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b @@ -2213,7 +2213,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -2236,17 +2236,17 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_d_mv_csc_from_coo -subroutine psb_d_mv_csc_to_fmt(a,b,info) +subroutine psb_d_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_to_fmt - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b @@ -2262,10 +2262,10 @@ subroutine psb_d_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_d_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_d_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -2282,12 +2282,12 @@ subroutine psb_d_mv_csc_to_fmt(a,b,info) end subroutine psb_d_mv_csc_to_fmt !!$ -subroutine psb_d_cp_csc_to_fmt(a,b,info) +subroutine psb_d_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_to_fmt - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b @@ -2303,10 +2303,10 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_d_csc_sparse_mat) + type is (psb_d_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat nc = a%get_ncols() @@ -2324,12 +2324,12 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info) end subroutine psb_d_cp_csc_to_fmt -subroutine psb_d_mv_csc_from_fmt(a,b,info) +subroutine psb_d_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_mv_csc_from_fmt - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b @@ -2345,10 +2345,10 @@ subroutine psb_d_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_d_csc_sparse_mat) + type is (psb_d_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat @@ -2369,19 +2369,19 @@ end subroutine psb_d_mv_csc_from_fmt subroutine psb_d_csc_clean_zeros(a, info) use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_clean_zeros - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nc - integer(psb_ipk_), allocatable :: ilcp(:) - + integer(psb_ipk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= dzero) then @@ -2396,12 +2396,12 @@ subroutine psb_d_csc_clean_zeros(a, info) call a%set_host() end subroutine psb_d_csc_clean_zeros -subroutine psb_d_cp_csc_from_fmt(a,b,info) +subroutine psb_d_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_cp_csc_from_fmt - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b @@ -2417,10 +2417,10 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_d_csc_sparse_mat) + type is (psb_d_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat nc = b%get_ncols() @@ -2435,14 +2435,14 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_d_cp_csc_from_fmt -subroutine psb_d_csc_mold(a,b,info) +subroutine psb_d_csc_mold(a,b,info) use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mold use psb_error_mod - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2452,16 +2452,16 @@ subroutine psb_d_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_d_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -2473,11 +2473,11 @@ subroutine psb_d_csc_mold(a,b,info) end subroutine psb_d_csc_mold -subroutine psb_d_csc_reallocate_nz(nz,a) +subroutine psb_d_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -2490,7 +2490,7 @@ subroutine psb_d_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -2508,7 +2508,7 @@ end subroutine psb_d_csc_reallocate_nz !!$subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& !!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ ! Output is always in COO format +!!$ ! Output is always in COO format !!$ use psb_error_mod !!$ use psb_const_mod !!$ use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csgetblk @@ -2531,12 +2531,12 @@ end subroutine psb_d_csc_reallocate_nz !!$ call psb_erractionsave(err_act) !!$ info = psb_success_ !!$ -!!$ if (present(append)) then +!!$ if (present(append)) then !!$ append_ = append !!$ else !!$ append_ = .false. !!$ endif -!!$ if (append_) then +!!$ if (append_) then !!$ nzin = a%get_nzeros() !!$ else !!$ nzin = 0 @@ -2564,9 +2564,9 @@ end subroutine psb_d_csc_reallocate_nz subroutine psb_d_csc_reinit(a,clear) use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_reinit - implicit none + implicit none - class(psb_d_csc_sparse_mat), intent(inout) :: a + class(psb_d_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2580,16 +2580,16 @@ subroutine psb_d_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = dzero call a%set_upd() call a%set_host() @@ -2612,7 +2612,7 @@ subroutine psb_d_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_trim - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, n integer(psb_ipk_) :: ierr(5) @@ -2627,7 +2627,7 @@ subroutine psb_d_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2637,11 +2637,11 @@ subroutine psb_d_csc_trim(a) end subroutine psb_d_csc_trim -subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -2652,26 +2652,26 @@ subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -2679,7 +2679,7 @@ subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -2702,25 +2702,27 @@ end subroutine psb_d_csc_allocate_mnnz subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_csc_print' logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='real' character(len=80) :: frmt - integer(psb_ipk_) :: i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2729,35 +2731,35 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -2770,7 +2772,7 @@ subroutine psb_dcscspspmm(a,b,c,info) use psb_d_mat_mod use psb_serial_mod, psb_protect_name => psb_dcscspspmm - implicit none + implicit none class(psb_d_csc_sparse_mat), intent(in) :: a,b type(psb_d_csc_sparse_mat), intent(out) :: c @@ -2790,7 +2792,7 @@ subroutine psb_dcscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -2819,9 +2821,9 @@ subroutine psb_dcscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_d_csc_sparse_mat), intent(in) :: a,b type(psb_d_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -2844,29 +2846,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -2874,11 +2876,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do @@ -2891,11 +2893,11 @@ end subroutine psb_dcscspspmm -subroutine psb_ld_csc_get_diag(a,d,info) +subroutine psb_ld_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_get_diag - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2910,28 +2912,28 @@ subroutine psb_ld_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = done + if (a%is_unit()) then + d(1:mnm) = done else do i=1, mnm d(i) = dzero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = dzero end do call psb_erractionrestore(err_act) @@ -2944,12 +2946,12 @@ subroutine psb_ld_csc_get_diag(a,d,info) end subroutine psb_ld_csc_get_diag -subroutine psb_ld_csc_scal(d,a,info,side) +subroutine psb_ld_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_scal use psb_string_mod - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2960,7 +2962,7 @@ subroutine psb_ld_csc_scal(d,a,info,side) integer(psb_ipk_) :: err_act,ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -2968,39 +2970,39 @@ subroutine psb_ld_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -3016,11 +3018,11 @@ subroutine psb_ld_csc_scal(d,a,info,side) end subroutine psb_ld_csc_scal -subroutine psb_ld_csc_scals(d,a,info) +subroutine psb_ld_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_scals - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3034,7 +3036,7 @@ subroutine psb_ld_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3056,7 +3058,7 @@ end subroutine psb_ld_csc_scals function psb_ld_csc_maxval(a) result(res) use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_maxval - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3065,7 +3067,7 @@ function psb_ld_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero @@ -3073,7 +3075,7 @@ function psb_ld_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3084,7 +3086,7 @@ function psb_ld_csc_csnm1(a) result(res) use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csnm1 - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3097,13 +3099,13 @@ function psb_ld_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = dzero + res = dzero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -3113,12 +3115,12 @@ function psb_ld_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_ld_csc_csnm1 -subroutine psb_ld_csc_colsum(d,a) +subroutine psb_ld_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_colsum @@ -3139,7 +3141,7 @@ subroutine psb_ld_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3147,19 +3149,19 @@ subroutine psb_ld_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = done else d(i) = dzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3167,7 +3169,7 @@ subroutine psb_ld_csc_colsum(d,a) end subroutine psb_ld_csc_colsum -subroutine psb_ld_csc_aclsum(d,a) +subroutine psb_ld_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_aclsum @@ -3188,7 +3190,7 @@ subroutine psb_ld_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3197,25 +3199,25 @@ subroutine psb_ld_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = done else d(i) = dzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3223,7 +3225,7 @@ subroutine psb_ld_csc_aclsum(d,a) end subroutine psb_ld_csc_aclsum -subroutine psb_ld_csc_rowsum(d,a) +subroutine psb_ld_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_rowsum @@ -3231,7 +3233,7 @@ subroutine psb_ld_csc_rowsum(d,a) real(psb_dpk_), intent(out) :: d(:) integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc - integer(psb_epk_) :: m,n + integer(psb_epk_) :: m,n real(psb_dpk_) :: acc real(psb_dpk_), allocatable :: vt(:) logical :: tra @@ -3245,14 +3247,14 @@ subroutine psb_ld_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -3266,7 +3268,7 @@ subroutine psb_ld_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3274,7 +3276,7 @@ subroutine psb_ld_csc_rowsum(d,a) end subroutine psb_ld_csc_rowsum -subroutine psb_ld_csc_arwsum(d,a) +subroutine psb_ld_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_arwsum @@ -3296,14 +3298,14 @@ subroutine psb_ld_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -3317,7 +3319,7 @@ subroutine psb_ld_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3326,7 +3328,7 @@ subroutine psb_ld_csc_arwsum(d,a) end subroutine psb_ld_csc_arwsum -! == =================================== +! == =================================== ! ! ! @@ -3336,11 +3338,11 @@ end subroutine psb_ld_csc_arwsum ! ! ! -! == =================================== +! == =================================== subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3358,7 +3360,7 @@ subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3387,35 +3389,35 @@ subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call lcsc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3461,12 +3463,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3477,19 +3479,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3503,9 +3505,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3517,9 +3519,9 @@ contains enddo end do end if - + end subroutine lcsc_getptn - + end subroutine psb_ld_csc_csgetptn @@ -3527,7 +3529,7 @@ end subroutine psb_ld_csc_csgetptn subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3546,7 +3548,7 @@ subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3556,7 +3558,7 @@ subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -3576,22 +3578,22 @@ subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -3599,13 +3601,13 @@ subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call lcsc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3653,12 +3655,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3669,7 +3671,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -3677,12 +3679,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3698,9 +3700,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3720,11 +3722,11 @@ end subroutine psb_ld_csc_csgetrow -subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csput_a - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -3743,26 +3745,26 @@ subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -3773,25 +3775,25 @@ subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_ld_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -3817,7 +3819,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -3835,13 +3837,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -3851,19 +3853,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -3876,18 +3878,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -3909,12 +3911,12 @@ contains end subroutine psb_ld_csc_csput_a -subroutine psb_ld_cp_csc_from_coo(a,b,info) +subroutine psb_ld_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_from_coo - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b @@ -3937,11 +3939,11 @@ end subroutine psb_ld_cp_csc_from_coo -subroutine psb_ld_cp_csc_to_coo(a,b,info) +subroutine psb_ld_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_to_coo - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -3971,7 +3973,7 @@ subroutine psb_ld_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -3979,12 +3981,12 @@ subroutine psb_ld_cp_csc_to_coo(a,b,info) end subroutine psb_ld_cp_csc_to_coo -subroutine psb_ld_mv_csc_to_coo(a,b,info) +subroutine psb_ld_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_to_coo - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -4021,13 +4023,13 @@ subroutine psb_ld_mv_csc_to_coo(a,b,info) end subroutine psb_ld_mv_csc_to_coo -subroutine psb_ld_mv_csc_from_coo(a,b,info) +subroutine psb_ld_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_from_coo - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -4051,7 +4053,7 @@ subroutine psb_ld_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -4074,17 +4076,17 @@ subroutine psb_ld_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_ld_mv_csc_from_coo -subroutine psb_ld_mv_csc_to_fmt(a,b,info) +subroutine psb_ld_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_to_fmt - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b @@ -4100,10 +4102,10 @@ subroutine psb_ld_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_ld_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_ld_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -4120,12 +4122,12 @@ subroutine psb_ld_mv_csc_to_fmt(a,b,info) end subroutine psb_ld_mv_csc_to_fmt !!$ -subroutine psb_ld_cp_csc_to_fmt(a,b,info) +subroutine psb_ld_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_to_fmt - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b @@ -4141,10 +4143,10 @@ subroutine psb_ld_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_ld_csc_sparse_mat) + type is (psb_ld_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat nc = a%get_ncols() @@ -4162,12 +4164,12 @@ subroutine psb_ld_cp_csc_to_fmt(a,b,info) end subroutine psb_ld_cp_csc_to_fmt -subroutine psb_ld_mv_csc_from_fmt(a,b,info) +subroutine psb_ld_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_from_fmt - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b @@ -4183,10 +4185,10 @@ subroutine psb_ld_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_ld_csc_sparse_mat) + type is (psb_ld_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat @@ -4206,12 +4208,12 @@ end subroutine psb_ld_mv_csc_from_fmt -subroutine psb_ld_cp_csc_from_fmt(a,b,info) +subroutine psb_ld_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_from_fmt - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b @@ -4227,10 +4229,10 @@ subroutine psb_ld_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_ld_csc_sparse_mat) + type is (psb_ld_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat nc = b%get_ncols() @@ -4245,25 +4247,25 @@ subroutine psb_ld_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_ld_cp_csc_from_fmt subroutine psb_ld_csc_clean_zeros(a, info) use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_clean_zeros - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nc - integer(psb_lpk_), allocatable :: ilcp(:) - + integer(psb_lpk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= dzero) then @@ -4279,10 +4281,10 @@ subroutine psb_ld_csc_clean_zeros(a, info) end subroutine psb_ld_csc_clean_zeros -subroutine psb_ld_csc_mold(a,b,info) +subroutine psb_ld_csc_mold(a,b,info) use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_mold use psb_error_mod - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4291,16 +4293,16 @@ subroutine psb_ld_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_ld_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4312,11 +4314,11 @@ subroutine psb_ld_csc_mold(a,b,info) end subroutine psb_ld_csc_mold -subroutine psb_ld_csc_reallocate_nz(nz,a) +subroutine psb_ld_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4328,7 +4330,7 @@ subroutine psb_ld_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4346,7 +4348,7 @@ end subroutine psb_ld_csc_reallocate_nz subroutine psb_ld_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csgetblk @@ -4369,12 +4371,12 @@ subroutine psb_ld_csc_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 @@ -4402,9 +4404,9 @@ end subroutine psb_ld_csc_csgetblk subroutine psb_ld_csc_reinit(a,clear) use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_reinit - implicit none + implicit none - class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4418,16 +4420,16 @@ subroutine psb_ld_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = dzero call a%set_upd() call a%set_host() @@ -4450,7 +4452,7 @@ subroutine psb_ld_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_trim - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, n integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4465,7 +4467,7 @@ subroutine psb_ld_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4475,11 +4477,11 @@ subroutine psb_ld_csc_trim(a) end subroutine psb_ld_csc_trim -subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_ld_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4490,26 +4492,26 @@ subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -4517,7 +4519,7 @@ subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -4540,24 +4542,25 @@ end subroutine psb_ld_csc_allocate_mnnz subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='ld_csc_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4566,36 +4569,36 @@ subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -4608,7 +4611,7 @@ subroutine psb_ldcscspspmm(a,b,c,info) use psb_d_mat_mod use psb_serial_mod, psb_protect_name => psb_ldcscspspmm - implicit none + implicit none class(psb_ld_csc_sparse_mat), intent(in) :: a,b type(psb_ld_csc_sparse_mat), intent(out) :: c @@ -4628,7 +4631,7 @@ subroutine psb_ldcscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -4657,9 +4660,9 @@ subroutine psb_ldcscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_ld_csc_sparse_mat), intent(in) :: a,b type(psb_ld_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -4682,29 +4685,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -4712,11 +4715,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index f264db26a..01f36eaab 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csmv - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -73,7 +73,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -83,7 +83,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_d_csr_csmm - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -418,7 +418,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -426,7 +426,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -434,16 +434,16 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_d_csr_cssv - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -766,7 +766,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -776,26 +776,26 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x) psb_d_csr_cssm - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1030,7 +1030,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1041,9 +1041,9 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1063,14 +1063,14 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == dzero) then + if (beta == dzero) then call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -1078,7 +1078,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) end if call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) end do @@ -1099,11 +1099,11 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,& - & irp,ja,val,x,ldx,y,ldy,info) - implicit none + & irp,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit integer(psb_ipk_), intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) real(psb_dpk_), intent(in) :: val(*), x(ldx,*) @@ -1120,38 +1120,38 @@ contains end if - if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then do i=1, nr - acc = dzero + acc = dzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr - acc = dzero + acc = dzero do j=irp(i), irp(i+1)-2 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then - do i=nr, 1, -1 - acc = dzero + if (unit) then + do i=nr, 1, -1 + acc = dzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then - do i=nr, 1, -1 - acc = dzero + else if (.not.unit) then + do i=nr, 1, -1 + acc = dzero do j=irp(i)+1, irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -1161,96 +1161,96 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/val(irp(i)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/(val(irp(i+1)-1)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/(val(irp(i))) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do end if @@ -1264,7 +1264,7 @@ end subroutine psb_d_csr_cssm function psb_d_csr_maxval(a) result(res) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_maxval - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1277,7 +1277,7 @@ function psb_d_csr_maxval(a) result(res) res = dzero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1286,7 +1286,7 @@ end function psb_d_csr_maxval function psb_d_csr_csnmi(a) result(res) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csnmi - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1303,7 +1303,7 @@ function psb_d_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -1311,7 +1311,7 @@ function psb_d_csr_csnmi(a) result(res) end function psb_d_csr_csnmi -subroutine psb_d_csr_rowsum(d,a) +subroutine psb_d_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_rowsum @@ -1331,7 +1331,7 @@ subroutine psb_d_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1340,12 +1340,12 @@ subroutine psb_d_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + done end do @@ -1353,7 +1353,7 @@ subroutine psb_d_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1361,7 +1361,7 @@ subroutine psb_d_csr_rowsum(d,a) end subroutine psb_d_csr_rowsum -subroutine psb_d_csr_arwsum(d,a) +subroutine psb_d_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_arwsum @@ -1381,7 +1381,7 @@ subroutine psb_d_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1391,19 +1391,19 @@ subroutine psb_d_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1411,7 +1411,7 @@ subroutine psb_d_csr_arwsum(d,a) end subroutine psb_d_csr_arwsum -subroutine psb_d_csr_colsum(d,a) +subroutine psb_d_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_colsum @@ -1432,7 +1432,7 @@ subroutine psb_d_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1447,8 +1447,8 @@ subroutine psb_d_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + done end do @@ -1456,7 +1456,7 @@ subroutine psb_d_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1464,7 +1464,7 @@ subroutine psb_d_csr_colsum(d,a) end subroutine psb_d_csr_colsum -subroutine psb_d_csr_aclsum(d,a) +subroutine psb_d_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_aclsum @@ -1485,7 +1485,7 @@ subroutine psb_d_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1500,8 +1500,8 @@ subroutine psb_d_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + done end do @@ -1509,7 +1509,7 @@ subroutine psb_d_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1517,11 +1517,11 @@ subroutine psb_d_csr_aclsum(d,a) end subroutine psb_d_csr_aclsum -subroutine psb_d_csr_get_diag(a,d,info) +subroutine psb_d_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_get_diag - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1536,28 +1536,28 @@ subroutine psb_d_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = done else do i=1, mnm d(i) = dzero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = dzero end do @@ -1570,12 +1570,12 @@ subroutine psb_d_csr_get_diag(a,d,info) end subroutine psb_d_csr_get_diag -subroutine psb_d_csr_scal(d,a,info,side) +subroutine psb_d_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scal use psb_string_mod - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1585,47 +1585,47 @@ subroutine psb_d_csr_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -1643,11 +1643,11 @@ subroutine psb_d_csr_scal(d,a,info,side) end subroutine psb_d_csr_scal -subroutine psb_d_csr_scals(d,a,info) +subroutine psb_d_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scals - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1660,7 +1660,7 @@ subroutine psb_d_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1680,7 +1680,7 @@ end subroutine psb_d_csr_scals -! == =================================== +! == =================================== ! ! ! @@ -1690,14 +1690,14 @@ end subroutine psb_d_csr_scals ! ! ! -! == =================================== +! == =================================== -subroutine psb_d_csr_reallocate_nz(nz,a) +subroutine psb_d_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1709,7 +1709,7 @@ subroutine psb_d_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -1723,10 +1723,10 @@ subroutine psb_d_csr_reallocate_nz(nz,a) end subroutine psb_d_csr_reallocate_nz -subroutine psb_d_csr_mold(a,b,info) +subroutine psb_d_csr_mold(a,b,info) use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mold use psb_error_mod - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1735,16 +1735,16 @@ subroutine psb_d_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_d_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -1755,11 +1755,11 @@ subroutine psb_d_csr_mold(a,b,info) end subroutine psb_d_csr_mold -subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1770,26 +1770,26 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -1797,7 +1797,7 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1820,7 +1820,7 @@ end subroutine psb_d_csr_allocate_mnnz subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1838,7 +1838,7 @@ subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -1866,35 +1866,35 @@ subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1940,32 +1940,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -1976,7 +1976,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -1987,13 +1987,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_d_csr_csgetptn subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2021,7 +2021,7 @@ subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -2040,27 +2040,27 @@ subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2068,13 +2068,13 @@ subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2121,12 +2121,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -2134,23 +2134,23 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - + if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2162,7 +2162,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2183,7 +2183,7 @@ end subroutine psb_d_csr_csgetrow ! subroutine psb_d_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_tril @@ -2195,7 +2195,7 @@ subroutine psb_d_csr_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_d_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2206,57 +2206,57 @@ subroutine psb_d_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -2265,7 +2265,7 @@ subroutine psb_d_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -2281,7 +2281,7 @@ subroutine psb_d_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -2289,17 +2289,17 @@ subroutine psb_d_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -2318,8 +2318,8 @@ subroutine psb_d_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -2337,7 +2337,7 @@ end subroutine psb_d_csr_tril subroutine psb_d_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_triu @@ -2349,7 +2349,7 @@ subroutine psb_d_csr_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_d_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2360,57 +2360,57 @@ subroutine psb_d_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -2419,7 +2419,7 @@ subroutine psb_d_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -2471,8 +2471,8 @@ subroutine psb_d_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -2489,11 +2489,11 @@ subroutine psb_d_csr_triu(a,u,info,& end subroutine psb_d_csr_triu -subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput_a - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -2511,23 +2511,23 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_; i=1 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_; i=2 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_; i=3 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_; i=4 call psb_errpush(info,name,i_err=(/i/)) goto 9999 @@ -2538,25 +2538,25 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_d_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2582,7 +2582,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2600,13 +2600,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2616,20 +2616,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2641,17 +2641,17 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2676,9 +2676,9 @@ end subroutine psb_d_csr_csput_a subroutine psb_d_csr_reinit(a,clear) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reinit - implicit none + implicit none - class(psb_d_csr_sparse_mat), intent(inout) :: a + class(psb_d_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2691,16 +2691,16 @@ subroutine psb_d_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = dzero call a%set_upd() call a%set_host() @@ -2723,9 +2723,9 @@ subroutine psb_d_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_trim - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz, m + integer(psb_ipk_) :: err_act, info, nz, m character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2738,7 +2738,7 @@ subroutine psb_d_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2752,10 +2752,10 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -2763,13 +2763,13 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='d_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2779,35 +2779,35 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) nz = a%get_nzeros() frmt = psb_d_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -2817,12 +2817,12 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_d_csr_print -subroutine psb_d_cp_csr_from_coo(a,b,info) +subroutine psb_d_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_coo - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b @@ -2840,18 +2840,18 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_d_base_sparse_mat = tmp%psb_d_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -2860,22 +2860,22 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -2891,17 +2891,17 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_d_cp_csr_from_coo -subroutine psb_d_cp_csr_to_coo(a,b,info) +subroutine psb_d_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_coo - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b @@ -2940,12 +2940,12 @@ subroutine psb_d_cp_csr_to_coo(a,b,info) end subroutine psb_d_cp_csr_to_coo -subroutine psb_d_mv_csr_to_coo(a,b,info) +subroutine psb_d_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_coo - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b @@ -2986,13 +2986,13 @@ end subroutine psb_d_mv_csr_to_coo -subroutine psb_d_mv_csr_from_coo(a,b,info) +subroutine psb_d_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_coo - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b @@ -3018,7 +3018,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -3042,15 +3042,15 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_d_mv_csr_from_coo -subroutine psb_d_mv_csr_to_fmt(a,b,info) +subroutine psb_d_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_fmt - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b @@ -3067,9 +3067,9 @@ subroutine psb_d_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_d_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat @@ -3087,12 +3087,12 @@ subroutine psb_d_mv_csr_to_fmt(a,b,info) end subroutine psb_d_mv_csr_to_fmt -subroutine psb_d_cp_csr_to_fmt(a,b,info) +subroutine psb_d_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_fmt - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b @@ -3110,10 +3110,10 @@ subroutine psb_d_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_d_csr_sparse_mat) + type is (psb_d_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat nr = a%get_nrows() @@ -3131,11 +3131,11 @@ subroutine psb_d_cp_csr_to_fmt(a,b,info) end subroutine psb_d_cp_csr_to_fmt -subroutine psb_d_mv_csr_from_fmt(a,b,info) +subroutine psb_d_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_fmt - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b @@ -3152,10 +3152,10 @@ subroutine psb_d_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_d_csr_sparse_mat) + type is (psb_d_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat @@ -3174,12 +3174,12 @@ end subroutine psb_d_mv_csr_from_fmt -subroutine psb_d_cp_csr_from_fmt(a,b,info) +subroutine psb_d_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_fmt - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b @@ -3196,10 +3196,10 @@ subroutine psb_d_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_d_coo_sparse_mat) + type is (psb_d_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_d_csr_sparse_mat) + type is (psb_d_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat nr = b%get_nrows() @@ -3218,19 +3218,19 @@ end subroutine psb_d_cp_csr_from_fmt subroutine psb_d_csr_clean_zeros(a, info) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_clean_zeros - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nr - integer(psb_ipk_), allocatable :: ilrp(:) - + integer(psb_ipk_), allocatable :: ilrp(:) + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= dzero) then @@ -3249,7 +3249,7 @@ subroutine psb_dcsrspspmm(a,b,c,info) use psb_d_mat_mod use psb_serial_mod, psb_protect_name => psb_dcsrspspmm - implicit none + implicit none class(psb_d_csr_sparse_mat), intent(in) :: a,b type(psb_d_csr_sparse_mat), intent(out) :: c @@ -3260,7 +3260,7 @@ subroutine psb_dcsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -3270,7 +3270,7 @@ subroutine psb_dcsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -3296,9 +3296,9 @@ subroutine psb_dcsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_d_csr_sparse_mat), intent(in) :: a,b type(psb_d_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -3321,49 +3321,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_dcsrspspmm @@ -3372,13 +3372,13 @@ end subroutine psb_dcsrspspmm ! ! ! ld version -! ! -subroutine psb_ld_csr_get_diag(a,d,info) +! +subroutine psb_ld_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_get_diag - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3393,28 +3393,28 @@ subroutine psb_ld_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = done else do i=1, mnm d(i) = dzero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = dzero end do @@ -3427,12 +3427,12 @@ subroutine psb_ld_csr_get_diag(a,d,info) end subroutine psb_ld_csr_get_diag -subroutine psb_ld_csr_scal(d,a,info,side) +subroutine psb_ld_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_scal use psb_string_mod - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3442,47 +3442,47 @@ subroutine psb_ld_csr_scal(d,a,info,side) integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -3500,11 +3500,11 @@ subroutine psb_ld_csr_scal(d,a,info,side) end subroutine psb_ld_csr_scal -subroutine psb_ld_csr_scals(d,a,info) +subroutine psb_ld_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_scals - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3518,7 +3518,7 @@ subroutine psb_ld_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3539,7 +3539,7 @@ end subroutine psb_ld_csr_scals function psb_ld_csr_maxval(a) result(res) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_maxval - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3552,7 +3552,7 @@ function psb_ld_csr_maxval(a) result(res) res = dzero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3561,7 +3561,7 @@ end function psb_ld_csr_maxval function psb_ld_csr_csnmi(a) result(res) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csnmi - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3578,7 +3578,7 @@ function psb_ld_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -3586,7 +3586,7 @@ function psb_ld_csr_csnmi(a) result(res) end function psb_ld_csr_csnmi -subroutine psb_ld_csr_rowsum(d,a) +subroutine psb_ld_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_rowsum @@ -3606,7 +3606,7 @@ subroutine psb_ld_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3615,12 +3615,12 @@ subroutine psb_ld_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + done end do @@ -3628,7 +3628,7 @@ subroutine psb_ld_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3636,7 +3636,7 @@ subroutine psb_ld_csr_rowsum(d,a) end subroutine psb_ld_csr_rowsum -subroutine psb_ld_csr_arwsum(d,a) +subroutine psb_ld_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_arwsum @@ -3656,7 +3656,7 @@ subroutine psb_ld_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3666,19 +3666,19 @@ subroutine psb_ld_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3686,7 +3686,7 @@ subroutine psb_ld_csr_arwsum(d,a) end subroutine psb_ld_csr_arwsum -subroutine psb_ld_csr_colsum(d,a) +subroutine psb_ld_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_colsum @@ -3707,7 +3707,7 @@ subroutine psb_ld_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3722,8 +3722,8 @@ subroutine psb_ld_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + done end do @@ -3731,7 +3731,7 @@ subroutine psb_ld_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3739,7 +3739,7 @@ subroutine psb_ld_csr_colsum(d,a) end subroutine psb_ld_csr_colsum -subroutine psb_ld_csr_aclsum(d,a) +subroutine psb_ld_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_aclsum @@ -3760,7 +3760,7 @@ subroutine psb_ld_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3775,8 +3775,8 @@ subroutine psb_ld_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + done end do @@ -3784,7 +3784,7 @@ subroutine psb_ld_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3793,7 +3793,7 @@ subroutine psb_ld_csr_aclsum(d,a) end subroutine psb_ld_csr_aclsum -! == =================================== +! == =================================== ! ! ! @@ -3803,14 +3803,14 @@ end subroutine psb_ld_csr_aclsum ! ! ! -! == =================================== +! == =================================== -subroutine psb_ld_csr_reallocate_nz(nz,a) +subroutine psb_ld_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_reallocate_nz - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ld_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3822,7 +3822,7 @@ subroutine psb_ld_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -3836,10 +3836,10 @@ subroutine psb_ld_csr_reallocate_nz(nz,a) end subroutine psb_ld_csr_reallocate_nz -subroutine psb_ld_csr_mold(a,b,info) +subroutine psb_ld_csr_mold(a,b,info) use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_mold use psb_error_mod - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3848,16 +3848,16 @@ subroutine psb_ld_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_ld_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -3868,11 +3868,11 @@ subroutine psb_ld_csr_mold(a,b,info) end subroutine psb_ld_csr_mold -subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_ld_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -3884,26 +3884,26 @@ subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -3911,7 +3911,7 @@ subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -3934,7 +3934,7 @@ end subroutine psb_ld_csr_allocate_mnnz subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3952,7 +3952,7 @@ subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -3981,35 +3981,35 @@ subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4055,32 +4055,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -4091,7 +4091,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -4102,13 +4102,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_ld_csr_csgetptn subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4127,7 +4127,7 @@ subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -4137,7 +4137,7 @@ subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -4156,22 +4156,22 @@ subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -4179,13 +4179,13 @@ subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4232,12 +4232,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -4245,21 +4245,21 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4271,7 +4271,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4292,7 +4292,7 @@ end subroutine psb_ld_csr_csgetrow ! subroutine psb_ld_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_tril @@ -4304,7 +4304,7 @@ subroutine psb_ld_csr_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ld_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4316,57 +4316,57 @@ subroutine psb_ld_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -4375,7 +4375,7 @@ subroutine psb_ld_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -4391,7 +4391,7 @@ subroutine psb_ld_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -4399,17 +4399,17 @@ subroutine psb_ld_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -4428,8 +4428,8 @@ subroutine psb_ld_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -4447,7 +4447,7 @@ end subroutine psb_ld_csr_tril subroutine psb_ld_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_triu @@ -4459,7 +4459,7 @@ subroutine psb_ld_csr_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ld_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4471,57 +4471,57 @@ subroutine psb_ld_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -4530,7 +4530,7 @@ subroutine psb_ld_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -4582,8 +4582,8 @@ subroutine psb_ld_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -4600,11 +4600,11 @@ subroutine psb_ld_csr_triu(a,u,info,& end subroutine psb_ld_csr_triu -subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csput_a - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -4624,24 +4624,24 @@ subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then - info = psb_err_iarg_neg_; + if (nz <= 0) then + info = psb_err_iarg_neg_; call psb_errpush(info,name,m_err=(/1/)) goto 9999 end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/2/)) goto 9999 end if - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/3/)) goto 9999 end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/4/)) goto 9999 end if @@ -4651,25 +4651,25 @@ subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_ld_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -4695,7 +4695,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -4713,13 +4713,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -4729,20 +4729,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 inc = nc - ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -4754,18 +4754,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 inc = nc ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -4790,9 +4790,9 @@ end subroutine psb_ld_csr_csput_a subroutine psb_ld_csr_reinit(a,clear) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_reinit - implicit none + implicit none - class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4805,16 +4805,16 @@ subroutine psb_ld_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = dzero call a%set_upd() call a%set_host() @@ -4837,7 +4837,7 @@ subroutine psb_ld_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_trim - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, m integer(psb_ipk_) :: err_act, info @@ -4853,7 +4853,7 @@ subroutine psb_ld_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4866,10 +4866,10 @@ end subroutine psb_ld_csr_trim subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4877,13 +4877,13 @@ subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='ld_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4892,36 +4892,36 @@ subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_ld_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -4931,12 +4931,12 @@ subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_ld_csr_print -subroutine psb_ld_cp_csr_from_coo(a,b,info) +subroutine psb_ld_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_from_coo - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(in) :: b @@ -4954,18 +4954,18 @@ subroutine psb_ld_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_ld_base_sparse_mat = tmp%psb_ld_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -4974,22 +4974,22 @@ subroutine psb_ld_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -5005,17 +5005,17 @@ subroutine psb_ld_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_ld_cp_csr_from_coo -subroutine psb_ld_cp_csr_to_coo(a,b,info) +subroutine psb_ld_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_to_coo - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -5054,12 +5054,12 @@ subroutine psb_ld_cp_csr_to_coo(a,b,info) end subroutine psb_ld_cp_csr_to_coo -subroutine psb_ld_mv_csr_to_coo(a,b,info) +subroutine psb_ld_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_to_coo - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -5100,13 +5100,13 @@ end subroutine psb_ld_mv_csr_to_coo -subroutine psb_ld_mv_csr_from_coo(a,b,info) +subroutine psb_ld_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_from_coo - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_coo_sparse_mat), intent(inout) :: b @@ -5132,7 +5132,7 @@ subroutine psb_ld_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -5156,15 +5156,15 @@ subroutine psb_ld_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_ld_mv_csr_from_coo -subroutine psb_ld_mv_csr_to_fmt(a,b,info) +subroutine psb_ld_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_to_fmt - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b @@ -5181,9 +5181,9 @@ subroutine psb_ld_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_ld_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat @@ -5201,12 +5201,12 @@ subroutine psb_ld_mv_csr_to_fmt(a,b,info) end subroutine psb_ld_mv_csr_to_fmt -subroutine psb_ld_cp_csr_to_fmt(a,b,info) +subroutine psb_ld_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_to_fmt - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b @@ -5224,10 +5224,10 @@ subroutine psb_ld_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_ld_csr_sparse_mat) + type is (psb_ld_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat nr = a%get_nrows() @@ -5245,11 +5245,11 @@ subroutine psb_ld_cp_csr_to_fmt(a,b,info) end subroutine psb_ld_cp_csr_to_fmt -subroutine psb_ld_mv_csr_from_fmt(a,b,info) +subroutine psb_ld_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_from_fmt - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b @@ -5266,10 +5266,10 @@ subroutine psb_ld_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_ld_csr_sparse_mat) + type is (psb_ld_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat @@ -5288,12 +5288,12 @@ end subroutine psb_ld_mv_csr_from_fmt -subroutine psb_ld_cp_csr_from_fmt(a,b,info) +subroutine psb_ld_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_d_base_mat_mod use psb_realloc_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_from_fmt - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(in) :: b @@ -5310,10 +5310,10 @@ subroutine psb_ld_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ld_coo_sparse_mat) + type is (psb_ld_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_ld_csr_sparse_mat) + type is (psb_ld_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat nr = b%get_nrows() @@ -5333,19 +5333,19 @@ end subroutine psb_ld_cp_csr_from_fmt subroutine psb_ld_csr_clean_zeros(a, info) use psb_error_mod use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_clean_zeros - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nr - integer(psb_lpk_), allocatable :: ilrp(:) - - info = 0 + integer(psb_lpk_), allocatable :: ilrp(:) + + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= dzero) then @@ -5364,7 +5364,7 @@ subroutine psb_ldcsrspspmm(a,b,c,info) use psb_d_mat_mod use psb_serial_mod, psb_protect_name => psb_ldcsrspspmm - implicit none + implicit none class(psb_ld_csr_sparse_mat), intent(in) :: a,b type(psb_ld_csr_sparse_mat), intent(out) :: c @@ -5375,7 +5375,7 @@ subroutine psb_ldcsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -5385,7 +5385,7 @@ subroutine psb_ldcsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -5410,9 +5410,9 @@ subroutine psb_ldcsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_ld_csr_sparse_mat), intent(in) :: a,b type(psb_ld_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -5435,50 +5435,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_ldcsrspspmm - diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 3a3490894..86de55367 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! d_mat_impl: ! implementation of the outer matrix methods. @@ -43,7 +43,7 @@ ! ! ! -! Setters +! Setters ! ! ! @@ -53,10 +53,10 @@ ! == =================================== -subroutine psb_d_set_nrows(m,a) +subroutine psb_d_set_nrows(m,a) use psb_d_mat_mod, psb_protect_name => psb_d_set_nrows use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -64,7 +64,7 @@ subroutine psb_d_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -82,10 +82,10 @@ subroutine psb_d_set_nrows(m,a) end subroutine psb_d_set_nrows -subroutine psb_d_set_ncols(n,a) +subroutine psb_d_set_ncols(n,a) use psb_d_mat_mod, psb_protect_name => psb_d_set_ncols use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -93,7 +93,7 @@ subroutine psb_d_set_ncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -112,16 +112,16 @@ end subroutine psb_d_set_ncols ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_d_set_dupl(n,a) +subroutine psb_d_set_dupl(n,a) use psb_d_mat_mod, psb_protect_name => psb_d_set_dupl use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -129,7 +129,7 @@ subroutine psb_d_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -151,17 +151,17 @@ end subroutine psb_d_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_d_set_null(a) +subroutine psb_d_set_null(a) use psb_d_mat_mod, psb_protect_name => psb_d_set_null use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -179,17 +179,17 @@ subroutine psb_d_set_null(a) end subroutine psb_d_set_null -subroutine psb_d_set_bld(a) +subroutine psb_d_set_bld(a) use psb_d_mat_mod, psb_protect_name => psb_d_set_bld use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -208,17 +208,17 @@ subroutine psb_d_set_bld(a) end subroutine psb_d_set_bld -subroutine psb_d_set_upd(a) +subroutine psb_d_set_upd(a) use psb_d_mat_mod, psb_protect_name => psb_d_set_upd use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -238,17 +238,17 @@ subroutine psb_d_set_upd(a) end subroutine psb_d_set_upd -subroutine psb_d_set_asb(a) +subroutine psb_d_set_asb(a) use psb_d_mat_mod, psb_protect_name => psb_d_set_asb use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -267,10 +267,10 @@ subroutine psb_d_set_asb(a) end subroutine psb_d_set_asb -subroutine psb_d_set_sorted(a,val) +subroutine psb_d_set_sorted(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_sorted use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -278,7 +278,7 @@ subroutine psb_d_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -297,10 +297,10 @@ subroutine psb_d_set_sorted(a,val) end subroutine psb_d_set_sorted -subroutine psb_d_set_triangle(a,val) +subroutine psb_d_set_triangle(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_triangle use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -308,7 +308,7 @@ subroutine psb_d_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -326,10 +326,10 @@ subroutine psb_d_set_triangle(a,val) end subroutine psb_d_set_triangle -subroutine psb_d_set_symmetric(a,val) +subroutine psb_d_set_symmetric(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -337,7 +337,7 @@ subroutine psb_d_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -355,10 +355,10 @@ subroutine psb_d_set_symmetric(a,val) end subroutine psb_d_set_symmetric -subroutine psb_d_set_unit(a,val) +subroutine psb_d_set_unit(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_unit use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -366,7 +366,7 @@ subroutine psb_d_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -385,10 +385,10 @@ subroutine psb_d_set_unit(a,val) end subroutine psb_d_set_unit -subroutine psb_d_set_lower(a,val) +subroutine psb_d_set_lower(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_lower use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -396,7 +396,7 @@ subroutine psb_d_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -415,10 +415,10 @@ subroutine psb_d_set_lower(a,val) end subroutine psb_d_set_lower -subroutine psb_d_set_upper(a,val) +subroutine psb_d_set_upper(a,val) use psb_d_mat_mod, psb_protect_name => psb_d_set_upper use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -426,7 +426,7 @@ subroutine psb_d_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -456,16 +456,16 @@ end subroutine psb_d_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) use psb_d_mat_mod, psb_protect_name => psb_d_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -476,7 +476,7 @@ subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -496,10 +496,10 @@ end subroutine psb_d_sparse_print subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_d_mat_mod, psb_protect_name => psb_d_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_dspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_dspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -511,24 +511,24 @@ subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -547,13 +547,13 @@ end subroutine psb_d_n_sparse_print subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) use psb_d_mat_mod, psb_protect_name => psb_d_get_neigh use psb_error_mod - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -561,7 +561,7 @@ subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -582,17 +582,17 @@ end subroutine psb_d_get_neigh -subroutine psb_d_csall(nr,nc,a,info,nz) +subroutine psb_d_csall(nr,nc,a,info,nz) use psb_d_mat_mod, psb_protect_name => psb_d_csall use psb_d_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -602,13 +602,13 @@ subroutine psb_d_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_d_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -619,10 +619,10 @@ subroutine psb_d_csall(nr,nc,a,info,nz) end subroutine psb_d_csall -subroutine psb_d_reallocate_nz(nz,a) +subroutine psb_d_reallocate_nz(nz,a) use psb_d_mat_mod, psb_protect_name => psb_d_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -630,7 +630,7 @@ subroutine psb_d_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -647,31 +647,31 @@ subroutine psb_d_reallocate_nz(nz,a) end subroutine psb_d_reallocate_nz -subroutine psb_d_free(a) +subroutine psb_d_free(a) use psb_d_mat_mod, psb_protect_name => psb_d_free use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_d_free -subroutine psb_d_trim(a) +subroutine psb_d_trim(a) use psb_d_mat_mod, psb_protect_name => psb_d_trim use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -689,11 +689,11 @@ end subroutine psb_d_trim -subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_mat_mod, psb_protect_name => psb_d_csput_a use psb_d_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -705,15 +705,15 @@ subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -725,13 +725,13 @@ subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_d_csput_a -subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_mat_mod, psb_protect_name => psb_d_csput_v use psb_d_base_mat_mod use psb_d_vect_mod, only : psb_d_vect_type use psb_i_vect_mod, only : psb_i_vect_type use psb_error_mod - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a type(psb_d_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -744,19 +744,19 @@ subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -771,7 +771,7 @@ end subroutine psb_d_csput_v subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -794,7 +794,7 @@ subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -803,7 +803,7 @@ subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -818,7 +818,7 @@ end subroutine psb_d_csgetptn subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -842,7 +842,7 @@ subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -851,7 +851,7 @@ subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -868,7 +868,7 @@ end subroutine psb_d_csgetrow subroutine psb_d_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -893,31 +893,31 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -936,7 +936,7 @@ subroutine psb_d_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_d_base_mat_mod use psb_d_mat_mod, psb_protect_name => psb_d_tril - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -951,22 +951,22 @@ subroutine psb_d_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -975,7 +975,7 @@ subroutine psb_d_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -993,7 +993,7 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_d_base_mat_mod use psb_d_mat_mod, psb_protect_name => psb_d_triu - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -1009,24 +1009,24 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -1035,7 +1035,7 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1047,9 +1047,10 @@ subroutine psb_d_triu(a,u,info,diag,imin,imax,& end subroutine psb_d_triu + subroutine psb_d_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -1069,24 +1070,24 @@ subroutine psb_d_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1099,7 +1100,7 @@ end subroutine psb_d_csclip subroutine psb_d_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -1118,14 +1119,14 @@ subroutine psb_d_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -1133,8 +1134,8 @@ subroutine psb_d_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1147,7 +1148,7 @@ end subroutine psb_d_csclip_ip subroutine psb_d_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -1166,7 +1167,7 @@ subroutine psb_d_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1174,7 +1175,7 @@ subroutine psb_d_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1190,7 +1191,7 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_cscnv - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1207,7 +1208,7 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1219,38 +1220,38 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_d_coo_sparse_mat :: altmp, stat=info) + allocate(psb_d_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_d_csc_sparse_mat :: altmp, stat=info) + allocate(psb_d_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -1268,7 +1269,7 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%set_asb() + call b%set_asb() call psb_erractionrestore(err_act) return @@ -1283,7 +1284,7 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_ip - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -1300,15 +1301,15 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -1318,29 +1319,29 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_d_csr_sparse_mat :: altmp, stat=info) + allocate(psb_d_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_d_coo_sparse_mat :: altmp, stat=info) + allocate(psb_d_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_d_csc_sparse_mat :: altmp, stat=info) + allocate(psb_d_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1359,7 +1360,7 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) call move_alloc(altmp,a%a) call a%trim() - call a%set_asb() + call a%set_asb() call psb_erractionrestore(err_act) return @@ -1376,7 +1377,7 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_base - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -1391,19 +1392,19 @@ subroutine psb_d_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -1425,7 +1426,7 @@ end subroutine psb_d_cscnv_base subroutine psb_d_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -1444,15 +1445,15 @@ subroutine psb_d_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1461,8 +1462,8 @@ subroutine psb_d_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1485,7 +1486,7 @@ end subroutine psb_d_clip_d subroutine psb_d_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -1503,13 +1504,13 @@ subroutine psb_d_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -1520,8 +1521,8 @@ subroutine psb_d_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1546,7 +1547,7 @@ subroutine psb_d_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_mv_from - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1564,7 +1565,7 @@ subroutine psb_d_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_from - implicit none + implicit none class(psb_dspmat_type), intent(out) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -1573,7 +1574,7 @@ subroutine psb_d_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -1582,8 +1583,8 @@ subroutine psb_d_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1599,11 +1600,11 @@ subroutine psb_d_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_mv_to - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -1614,7 +1615,7 @@ subroutine psb_d_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_to - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1631,14 +1632,14 @@ subroutine psb_d_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_d_mold subroutine psb_dspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_dspmat_type_move - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1659,7 +1660,7 @@ subroutine psb_dspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_dspmat_clone - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1671,10 +1672,10 @@ subroutine psb_dspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1691,7 +1692,7 @@ subroutine psb_d_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_transp_1mat - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1700,7 +1701,7 @@ subroutine psb_d_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1724,7 +1725,7 @@ subroutine psb_d_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_transp_2mat - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b @@ -1734,18 +1735,18 @@ subroutine psb_d_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -1762,7 +1763,7 @@ subroutine psb_d_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_transc_1mat - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1771,7 +1772,7 @@ subroutine psb_d_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1795,7 +1796,7 @@ subroutine psb_d_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_d_transc_2mat - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b @@ -1805,18 +1806,18 @@ subroutine psb_d_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -1832,9 +1833,9 @@ end subroutine psb_d_transc_2mat subroutine psb_d_asb(a,mold) use psb_d_mat_mod, psb_protect_name => psb_d_asb use psb_error_mod - implicit none + implicit none - class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), optional, intent(in) :: mold class(psb_d_base_sparse_mat), allocatable :: tmp class(psb_d_base_sparse_mat), pointer :: mld @@ -1842,15 +1843,15 @@ subroutine psb_d_asb(a,mold) character(len=20) :: name='d_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -1861,7 +1862,7 @@ subroutine psb_d_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -1876,21 +1877,21 @@ end subroutine psb_d_asb subroutine psb_d_reinit(a,clear) use psb_d_mat_mod, psb_protect_name => psb_d_reinit use psb_error_mod - implicit none + implicit none - class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -1925,10 +1926,10 @@ end subroutine psb_d_reinit ! == =================================== -subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_d_mat_mod, psb_protect_name => psb_d_csmm - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1940,14 +1941,14 @@ subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1958,10 +1959,10 @@ subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_d_csmm -subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_d_mat_mod, psb_protect_name => psb_d_csmv - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1973,14 +1974,14 @@ subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1990,11 +1991,11 @@ subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_d_csmv -subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) +subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_d_vect_mod use psb_d_mat_mod, psb_protect_name => psb_d_csmv_vect - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta type(psb_d_vect_type), intent(inout) :: x @@ -2007,25 +2008,25 @@ subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x%v,beta,y%v,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2037,10 +2038,10 @@ end subroutine psb_d_csmv_vect -subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_d_mat_mod, psb_protect_name => psb_d_cssm - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -2053,14 +2054,14 @@ subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2072,10 +2073,10 @@ subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_d_cssm -subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_d_mat_mod, psb_protect_name => psb_d_cssv - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -2088,15 +2089,15 @@ subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2108,11 +2109,11 @@ subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_d_cssv -subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_d_vect_mod use psb_d_mat_mod, psb_protect_name => psb_d_cssv_vect - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta type(psb_d_vect_type), intent(inout) :: x @@ -2126,33 +2127,33 @@ subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then + if (present(d)) then + if (.not.allocated(d%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2167,7 +2168,7 @@ function psb_d_maxval(a) result(res) use psb_d_mat_mod, psb_protect_name => psb_d_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -2178,7 +2179,7 @@ function psb_d_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2198,7 +2199,7 @@ function psb_d_csnmi(a) result(res) use psb_d_mat_mod, psb_protect_name => psb_d_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -2208,7 +2209,7 @@ function psb_d_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2229,7 +2230,7 @@ function psb_d_csnm1(a) result(res) use psb_d_mat_mod, psb_protect_name => psb_d_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -2239,7 +2240,7 @@ function psb_d_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2260,7 +2261,7 @@ function psb_d_rowsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_d_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2272,7 @@ function psb_d_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2293,7 +2294,7 @@ function psb_d_arwsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_d_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2304,7 +2305,7 @@ function psb_d_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2327,7 +2328,7 @@ function psb_d_colsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_d_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2338,7 +2339,7 @@ function psb_d_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2361,7 +2362,7 @@ function psb_d_aclsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_d_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2372,7 +2373,7 @@ function psb_d_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2396,7 +2397,7 @@ function psb_d_get_diag(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_d_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2407,14 +2408,14 @@ function psb_d_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -2435,7 +2436,7 @@ subroutine psb_d_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_scal - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2447,7 +2448,7 @@ subroutine psb_d_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2470,7 +2471,7 @@ subroutine psb_d_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_scals - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -2481,7 +2482,7 @@ subroutine psb_d_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2499,12 +2500,152 @@ subroutine psb_d_scals(d,a,info) end subroutine psb_d_scals +subroutine psb_d_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_scalplusidentity + implicit none + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_scalplusidentity + +subroutine psb_d_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_spaxpby + implicit none + real(psb_dpk_), intent(in) :: alpha + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: beta + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_spaxpby + +function psb_d_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cmpval + implicit none + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_d_cmpval + +function psb_d_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cmpmat + implicit none + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_d_cmpmat + subroutine psb_d_mv_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_mv_from_lb - implicit none - + implicit none + class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2512,16 +2653,16 @@ subroutine psb_d_mv_from_lb(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) - + end subroutine psb_d_mv_from_lb - + subroutine psb_d_cp_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_from_lb - implicit none - + implicit none + class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2536,30 +2677,30 @@ subroutine psb_d_mv_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_mv_to_lb - implicit none - + implicit none + class(psb_dspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_lfmt(b,info) call a%free() end if - + end subroutine psb_d_mv_to_lb subroutine psb_d_cp_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_to_lb - implicit none + implicit none class(psb_dspmat_type), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -2572,7 +2713,7 @@ subroutine psb_d_mv_from_l(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_mv_from_l - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -2585,21 +2726,21 @@ subroutine psb_d_mv_from_l(a,b) call a%free() end if call b%free() - + end subroutine psb_d_mv_from_l - + subroutine psb_d_cp_from_l(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_from_l - implicit none + implicit none class(psb_dspmat_type), intent(out) :: a class(psb_ldspmat_type), intent(in) :: b integer(psb_ipk_) :: info - info = psb_success_ + info = psb_success_ if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_lfmt(b%a,info) @@ -2612,12 +2753,12 @@ subroutine psb_d_mv_to_l(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_mv_to_l - implicit none + implicit none class(psb_dspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_ld_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_lfmt(b%a,info) @@ -2625,26 +2766,26 @@ subroutine psb_d_mv_to_l(a,b) call b%free() end if call a%free() - + end subroutine psb_d_mv_to_l subroutine psb_d_cp_to_l(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_d_cp_to_l - implicit none - + implicit none + class(psb_dspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_ld_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_lfmt(b%a,info) else call b%free() end if - + end subroutine psb_d_cp_to_l @@ -2654,10 +2795,10 @@ end subroutine psb_d_cp_to_l ! -subroutine psb_ld_set_lnrows(m,a) +subroutine psb_ld_set_lnrows(m,a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_lnrows use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2665,7 +2806,7 @@ subroutine psb_ld_set_lnrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2683,10 +2824,10 @@ subroutine psb_ld_set_lnrows(m,a) end subroutine psb_ld_set_lnrows #if defined(IPK4) && defined(LPK8) -subroutine psb_ld_set_inrows(m,a) +subroutine psb_ld_set_inrows(m,a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_inrows use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2694,7 +2835,7 @@ subroutine psb_ld_set_inrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2712,10 +2853,10 @@ subroutine psb_ld_set_inrows(m,a) end subroutine psb_ld_set_inrows #endif -subroutine psb_ld_set_lncols(n,a) +subroutine psb_ld_set_lncols(n,a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_lncols use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2723,7 +2864,7 @@ subroutine psb_ld_set_lncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2740,10 +2881,10 @@ subroutine psb_ld_set_lncols(n,a) end subroutine psb_ld_set_lncols #if defined(IPK4) && defined(LPK8) -subroutine psb_ld_set_incols(n,a) +subroutine psb_ld_set_incols(n,a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_incols use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2751,7 +2892,7 @@ subroutine psb_ld_set_incols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2770,16 +2911,16 @@ end subroutine psb_ld_set_incols #endif ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_ld_set_dupl(n,a) +subroutine psb_ld_set_dupl(n,a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_dupl use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2787,7 +2928,7 @@ subroutine psb_ld_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2809,17 +2950,17 @@ end subroutine psb_ld_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_ld_set_null(a) +subroutine psb_ld_set_null(a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_null use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2837,17 +2978,17 @@ subroutine psb_ld_set_null(a) end subroutine psb_ld_set_null -subroutine psb_ld_set_bld(a) +subroutine psb_ld_set_bld(a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_bld use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2866,17 +3007,17 @@ subroutine psb_ld_set_bld(a) end subroutine psb_ld_set_bld -subroutine psb_ld_set_upd(a) +subroutine psb_ld_set_upd(a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_upd use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2896,17 +3037,17 @@ subroutine psb_ld_set_upd(a) end subroutine psb_ld_set_upd -subroutine psb_ld_set_asb(a) +subroutine psb_ld_set_asb(a) use psb_d_mat_mod, psb_protect_name => psb_ld_set_asb use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2925,10 +3066,10 @@ subroutine psb_ld_set_asb(a) end subroutine psb_ld_set_asb -subroutine psb_ld_set_sorted(a,val) +subroutine psb_ld_set_sorted(a,val) use psb_d_mat_mod, psb_protect_name => psb_ld_set_sorted use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2936,7 +3077,7 @@ subroutine psb_ld_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2955,10 +3096,10 @@ subroutine psb_ld_set_sorted(a,val) end subroutine psb_ld_set_sorted -subroutine psb_ld_set_triangle(a,val) +subroutine psb_ld_set_triangle(a,val) use psb_d_mat_mod, psb_protect_name => psb_ld_set_triangle use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2966,7 +3107,7 @@ subroutine psb_ld_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2984,10 +3125,10 @@ subroutine psb_ld_set_triangle(a,val) end subroutine psb_ld_set_triangle -subroutine psb_ld_set_symmetric(a,val) +subroutine psb_ld_set_symmetric(a,val) use psb_d_mat_mod, psb_protect_name => psb_ld_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2995,7 +3136,7 @@ subroutine psb_ld_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3013,10 +3154,10 @@ subroutine psb_ld_set_symmetric(a,val) end subroutine psb_ld_set_symmetric -subroutine psb_ld_set_unit(a,val) +subroutine psb_ld_set_unit(a,val) use psb_d_mat_mod, psb_protect_name => psb_ld_set_unit use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3024,7 +3165,7 @@ subroutine psb_ld_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3043,10 +3184,10 @@ subroutine psb_ld_set_unit(a,val) end subroutine psb_ld_set_unit -subroutine psb_ld_set_lower(a,val) +subroutine psb_ld_set_lower(a,val) use psb_d_mat_mod, psb_protect_name => psb_ld_set_lower use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3054,7 +3195,7 @@ subroutine psb_ld_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3073,10 +3214,10 @@ subroutine psb_ld_set_lower(a,val) end subroutine psb_ld_set_lower -subroutine psb_ld_set_upper(a,val) +subroutine psb_ld_set_upper(a,val) use psb_d_mat_mod, psb_protect_name => psb_ld_set_upper use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3084,7 +3225,7 @@ subroutine psb_ld_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3114,16 +3255,16 @@ end subroutine psb_ld_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) use psb_d_mat_mod, psb_protect_name => psb_ld_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3134,7 +3275,7 @@ subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3154,10 +3295,10 @@ end subroutine psb_ld_sparse_print subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_d_mat_mod, psb_protect_name => psb_ld_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_ldspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_ldspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3169,24 +3310,24 @@ subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -3205,13 +3346,13 @@ end subroutine psb_ld_n_sparse_print subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) use psb_d_mat_mod, psb_protect_name => psb_ld_get_neigh use psb_error_mod - implicit none - class(psb_ldspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -3219,7 +3360,7 @@ subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3240,17 +3381,17 @@ end subroutine psb_ld_get_neigh -subroutine psb_ld_csall(nr,nc,a,info,nz) +subroutine psb_ld_csall(nr,nc,a,info,nz) use psb_d_mat_mod, psb_protect_name => psb_ld_csall use psb_d_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -3260,13 +3401,13 @@ subroutine psb_ld_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -3277,10 +3418,10 @@ subroutine psb_ld_csall(nr,nc,a,info,nz) end subroutine psb_ld_csall -subroutine psb_ld_reallocate_nz(nz,a) +subroutine psb_ld_reallocate_nz(nz,a) use psb_d_mat_mod, psb_protect_name => psb_ld_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3288,7 +3429,7 @@ subroutine psb_ld_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3305,31 +3446,31 @@ subroutine psb_ld_reallocate_nz(nz,a) end subroutine psb_ld_reallocate_nz -subroutine psb_ld_free(a) +subroutine psb_ld_free(a) use psb_d_mat_mod, psb_protect_name => psb_ld_free use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_ld_free -subroutine psb_ld_trim(a) +subroutine psb_ld_trim(a) use psb_d_mat_mod, psb_protect_name => psb_ld_trim use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3347,11 +3488,11 @@ end subroutine psb_ld_trim -subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_mat_mod, psb_protect_name => psb_ld_csput_a use psb_d_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -3363,15 +3504,15 @@ subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3383,13 +3524,13 @@ subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_ld_csput_a -subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_d_mat_mod, psb_protect_name => psb_ld_csput_v use psb_d_base_mat_mod use psb_d_vect_mod, only : psb_d_vect_type use psb_l_vect_mod, only : psb_l_vect_type use psb_error_mod - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a type(psb_d_vect_type), intent(inout) :: val type(psb_l_vect_type), intent(inout) :: ia, ja @@ -3402,19 +3543,19 @@ subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3429,7 +3570,7 @@ end subroutine psb_ld_csput_v subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -3452,7 +3593,7 @@ subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3461,7 +3602,7 @@ subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3476,7 +3617,7 @@ end subroutine psb_ld_csgetptn subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -3500,7 +3641,7 @@ subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3509,7 +3650,7 @@ subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3526,7 +3667,7 @@ end subroutine psb_ld_csgetrow subroutine psb_ld_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -3551,31 +3692,31 @@ subroutine psb_ld_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3594,7 +3735,7 @@ subroutine psb_ld_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_d_base_mat_mod use psb_d_mat_mod, psb_protect_name => psb_ld_tril - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -3609,22 +3750,22 @@ subroutine psb_ld_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3633,7 +3774,7 @@ subroutine psb_ld_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3651,7 +3792,7 @@ subroutine psb_ld_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_d_base_mat_mod use psb_d_mat_mod, psb_protect_name => psb_ld_triu - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -3667,24 +3808,24 @@ subroutine psb_ld_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3693,7 +3834,7 @@ subroutine psb_ld_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3708,7 +3849,7 @@ end subroutine psb_ld_triu subroutine psb_ld_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -3728,24 +3869,24 @@ subroutine psb_ld_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3758,7 +3899,7 @@ end subroutine psb_ld_csclip subroutine psb_ld_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -3777,14 +3918,14 @@ subroutine psb_ld_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -3792,8 +3933,8 @@ subroutine psb_ld_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3806,7 +3947,7 @@ end subroutine psb_ld_csclip_ip subroutine psb_ld_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -3825,7 +3966,7 @@ subroutine psb_ld_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3833,7 +3974,7 @@ subroutine psb_ld_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3852,7 +3993,7 @@ subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3869,7 +4010,7 @@ subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3881,38 +4022,38 @@ subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) + allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) + allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) + allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -3930,7 +4071,7 @@ subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%asb() + call b%asb() call psb_erractionrestore(err_act) return @@ -3947,7 +4088,7 @@ subroutine psb_ld_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv_ip - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3964,15 +4105,15 @@ subroutine psb_ld_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -3982,29 +4123,29 @@ subroutine psb_ld_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) + allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) + allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) + allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4022,7 +4163,7 @@ subroutine psb_ld_cscnv_ip(a,info,type,mold,dupl) end if call move_alloc(altmp,a%a) - call a%set_asb() + call a%set_asb() call a%trim() call psb_erractionrestore(err_act) return @@ -4040,7 +4181,7 @@ subroutine psb_ld_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv_base - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ld_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -4055,19 +4196,19 @@ subroutine psb_ld_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -4089,7 +4230,7 @@ end subroutine psb_ld_cscnv_base subroutine psb_ld_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -4108,15 +4249,15 @@ subroutine psb_ld_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4125,8 +4266,8 @@ subroutine psb_ld_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4149,7 +4290,7 @@ end subroutine psb_ld_clip_d subroutine psb_ld_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_d_base_mat_mod @@ -4167,13 +4308,13 @@ subroutine psb_ld_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -4184,8 +4325,8 @@ subroutine psb_ld_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4210,7 +4351,7 @@ subroutine psb_ld_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4228,7 +4369,7 @@ subroutine psb_ld_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from - implicit none + implicit none class(psb_ldspmat_type), intent(out) :: a class(psb_ld_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -4237,7 +4378,7 @@ subroutine psb_ld_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -4246,8 +4387,8 @@ subroutine psb_ld_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4263,11 +4404,11 @@ subroutine psb_ld_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -4278,7 +4419,7 @@ subroutine psb_ld_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ld_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4295,14 +4436,14 @@ subroutine psb_ld_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_ld_mold subroutine psb_ldspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ldspmat_type_move - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4323,7 +4464,7 @@ subroutine psb_ldspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ldspmat_clone - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a class(psb_ldspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4335,10 +4476,10 @@ subroutine psb_ldspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4355,7 +4496,7 @@ subroutine psb_ld_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_transp_1mat - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4364,7 +4505,7 @@ subroutine psb_ld_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4388,7 +4529,7 @@ subroutine psb_ld_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_transp_2mat - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: b @@ -4398,18 +4539,18 @@ subroutine psb_ld_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -4426,7 +4567,7 @@ subroutine psb_ld_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_transc_1mat - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4435,7 +4576,7 @@ subroutine psb_ld_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4459,7 +4600,7 @@ subroutine psb_ld_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_d_mat_mod, psb_protect_name => psb_ld_transc_2mat - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_ldspmat_type), intent(inout) :: b @@ -4469,18 +4610,18 @@ subroutine psb_ld_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -4496,9 +4637,9 @@ end subroutine psb_ld_transc_2mat subroutine psb_ld_asb(a,mold) use psb_d_mat_mod, psb_protect_name => psb_ld_asb use psb_error_mod - implicit none + implicit none - class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: a class(psb_ld_base_sparse_mat), optional, intent(in) :: mold class(psb_ld_base_sparse_mat), allocatable :: tmp class(psb_ld_base_sparse_mat), pointer :: mld @@ -4506,15 +4647,15 @@ subroutine psb_ld_asb(a,mold) character(len=20) :: name='ld_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -4525,7 +4666,7 @@ subroutine psb_ld_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -4540,21 +4681,21 @@ end subroutine psb_ld_asb subroutine psb_ld_reinit(a,clear) use psb_d_mat_mod, psb_protect_name => psb_ld_reinit use psb_error_mod - implicit none + implicit none - class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -4579,7 +4720,7 @@ function psb_ld_get_diag(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_ld_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4590,14 +4731,14 @@ function psb_ld_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -4618,7 +4759,7 @@ subroutine psb_ld_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_scal - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4630,7 +4771,7 @@ subroutine psb_ld_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4653,7 +4794,7 @@ subroutine psb_ld_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_scals - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4664,7 +4805,7 @@ subroutine psb_ld_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4682,11 +4823,151 @@ subroutine psb_ld_scals(d,a,info) end subroutine psb_ld_scals +subroutine psb_ld_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_scalplusidentity + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_scalplusidentity + +subroutine psb_ld_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_spaxpby + implicit none + real(psb_dpk_), intent(in) :: alpha + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: beta + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_spaxpby + +function psb_ld_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cmpval + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_cmpval + +function psb_ld_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cmpmat + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_cmpmat + function psb_ld_maxval(a) result(res) use psb_d_mat_mod, psb_protect_name => psb_ld_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -4697,7 +4978,7 @@ function psb_ld_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4717,7 +4998,7 @@ function psb_ld_csnmi(a) result(res) use psb_d_mat_mod, psb_protect_name => psb_ld_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -4727,7 +5008,7 @@ function psb_ld_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4747,7 +5028,7 @@ function psb_ld_csnm1(a) result(res) use psb_d_mat_mod, psb_protect_name => psb_ld_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -4757,7 +5038,7 @@ function psb_ld_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4778,7 +5059,7 @@ function psb_ld_rowsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_ld_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4789,7 +5070,7 @@ function psb_ld_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4811,7 +5092,7 @@ function psb_ld_arwsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_ld_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4822,7 +5103,7 @@ function psb_ld_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4845,7 +5126,7 @@ function psb_ld_colsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_ld_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4856,7 +5137,7 @@ function psb_ld_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4879,7 +5160,7 @@ function psb_ld_aclsum(a,info) result(d) use psb_d_mat_mod, psb_protect_name => psb_ld_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4890,7 +5171,7 @@ function psb_ld_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4913,8 +5194,8 @@ subroutine psb_ld_mv_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from_ib - implicit none - + implicit none + class(psb_ldspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4922,15 +5203,15 @@ subroutine psb_ld_mv_from_ib(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_ifmt(b,info) - + end subroutine psb_ld_mv_from_ib - + subroutine psb_ld_cp_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from_ib - implicit none - + implicit none + class(psb_ldspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4945,30 +5226,30 @@ subroutine psb_ld_mv_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to_ib - implicit none - + implicit none + class(psb_ldspmat_type), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_ifmt(b,info) call a%free() end if - + end subroutine psb_ld_mv_to_ib subroutine psb_ld_cp_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to_ib - implicit none + implicit none class(psb_ldspmat_type), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -4981,7 +5262,7 @@ subroutine psb_ld_mv_from_i(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from_i - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -4993,20 +5274,20 @@ subroutine psb_ld_mv_from_i(a,b) call a%free() end if call b%free() - + end subroutine psb_ld_mv_from_i - + subroutine psb_ld_cp_from_i(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from_i - implicit none + implicit none class(psb_ldspmat_type), intent(out) :: a class(psb_dspmat_type), intent(in) :: b integer(psb_ipk_) :: info - + if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_ifmt(b%a,info) @@ -5019,12 +5300,12 @@ subroutine psb_ld_mv_to_i(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to_i - implicit none + implicit none class(psb_ldspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_d_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_ifmt(b%a,info) @@ -5032,28 +5313,24 @@ subroutine psb_ld_mv_to_i(a,b) call b%free() end if call a%free() - + end subroutine psb_ld_mv_to_i subroutine psb_ld_cp_to_i(a,b) use psb_error_mod use psb_const_mod use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to_i - implicit none - + implicit none + class(psb_ldspmat_type), intent(in) :: a class(psb_dspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_d_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_ifmt(b%a,info) else call b%free() end if - + end subroutine psb_ld_cp_to_i - - - - diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 1505ba405..7a3f647da 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == ================================== ! ! @@ -45,7 +45,7 @@ subroutine psb_s_base_cp_to_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -69,7 +69,7 @@ subroutine psb_s_base_cp_from_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -94,7 +94,7 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -103,10 +103,10 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -117,12 +117,12 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -136,7 +136,7 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -148,10 +148,10 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_s_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -160,8 +160,8 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -181,7 +181,7 @@ subroutine psb_s_base_mv_to_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -193,17 +193,17 @@ subroutine psb_s_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -218,7 +218,7 @@ subroutine psb_s_base_mv_from_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -229,17 +229,17 @@ subroutine psb_s_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -255,7 +255,7 @@ subroutine psb_s_base_mv_to_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -267,7 +267,7 @@ subroutine psb_s_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_s_coo_sparse_mat) @@ -285,7 +285,7 @@ subroutine psb_s_base_mv_from_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ subroutine psb_s_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_s_coo_sparse_mat) @@ -313,23 +313,23 @@ end subroutine psb_s_base_mv_from_fmt subroutine psb_s_base_clean_zeros(a, info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_clean_zeros - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_s_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_s_base_clean_zeros -subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_a - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -350,11 +350,11 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_s_base_csput_a -subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_v use psb_s_base_vect_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -366,24 +366,24 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() if (ia%is_dev()) call ia%sync() if (ja%is_dev()) call ja%sync() - call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -395,7 +395,7 @@ end subroutine psb_s_base_csput_v subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csgetrow @@ -433,7 +433,7 @@ end subroutine psb_s_base_csgetrow ! subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csgetblk @@ -456,22 +456,22 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -486,19 +486,19 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 's_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -526,7 +526,7 @@ end subroutine psb_s_base_csgetblk subroutine psb_s_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csclip @@ -547,46 +547,46 @@ subroutine psb_s_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -615,7 +615,7 @@ end subroutine psb_s_base_csclip ! subroutine psb_s_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_tril @@ -627,8 +627,8 @@ subroutine psb_s_base_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_s_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_spk_), allocatable :: val(:) @@ -640,51 +640,51 @@ subroutine psb_s_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -716,7 +716,7 @@ subroutine psb_s_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -724,8 +724,8 @@ subroutine psb_s_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -738,7 +738,7 @@ subroutine psb_s_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -747,8 +747,8 @@ subroutine psb_s_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -766,7 +766,7 @@ end subroutine psb_s_base_tril subroutine psb_s_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_triu @@ -778,7 +778,7 @@ subroutine psb_s_base_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_s_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) @@ -791,57 +791,57 @@ subroutine psb_s_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -874,13 +874,13 @@ subroutine psb_s_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -888,7 +888,7 @@ subroutine psb_s_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -897,8 +897,8 @@ subroutine psb_s_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -919,45 +919,45 @@ end subroutine psb_s_base_triu subroutine psb_s_base_clone(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_s_base_clone subroutine psb_s_base_make_nonunit(a) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: i, j, m, n, nz, mnm, info - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + integer(psb_ipk_) :: i, j, m, n, nz, mnm, info + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -974,10 +974,10 @@ subroutine psb_s_base_make_nonunit(a) end subroutine psb_s_base_make_nonunit -subroutine psb_s_base_mold(a,b,info) +subroutine psb_s_base_mold(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mold use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -999,7 +999,7 @@ end subroutine psb_s_base_mold subroutine psb_s_base_transp_2mat(a,b) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1019,11 +1019,11 @@ subroutine psb_s_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1035,7 +1035,7 @@ end subroutine psb_s_base_transp_2mat subroutine psb_s_base_transc_2mat(a,b) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transc_2mat - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1055,11 +1055,11 @@ subroutine psb_s_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1071,7 +1071,7 @@ end subroutine psb_s_base_transc_2mat subroutine psb_s_base_transp_1mat(a) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a @@ -1085,12 +1085,12 @@ subroutine psb_s_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1102,7 +1102,7 @@ end subroutine psb_s_base_transp_1mat subroutine psb_s_base_transc_1mat(a) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transc_1mat - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a @@ -1116,12 +1116,12 @@ subroutine psb_s_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1145,11 +1145,11 @@ end subroutine psb_s_base_transc_1mat ! ! == ================================== -subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmm use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1172,10 +1172,10 @@ subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_s_base_csmm -subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csmv use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1199,10 +1199,10 @@ subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_s_base_csmv -subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_cssm use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1225,10 +1225,10 @@ subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) end subroutine psb_s_base_inner_cssm -subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_cssv use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1251,11 +1251,11 @@ subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) end subroutine psb_s_base_inner_cssv -subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cssm use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1271,7 +1271,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1291,42 +1291,42 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) + tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ @@ -1334,21 +1334,21 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(sone,x,szero,tmp,info,trans) - if (info == psb_success_)then + if (info == psb_success_)then do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) + tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if @@ -1357,13 +1357,13 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -1378,11 +1378,11 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_s_base_cssm -subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cssv use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1418,58 +1418,58 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == szero) then + if (beta == szero) then call a%inner_spsm(alpha,x,szero,y,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,y) else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,szero,tmp,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,tmp) if (info == psb_success_)& & call psb_geaxpby(nar,sone,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1479,13 +1479,13 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1500,37 +1500,37 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return contains subroutine inner_vscal(n,d,x,y) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n real(psb_spk_), intent(in) :: d(*),x(*) real(psb_spk_), intent(out) :: y(*) integer(psb_ipk_) :: i do i=1,n - y(i) = d(i)*x(i) + y(i) = d(i)*x(i) end do end subroutine inner_vscal subroutine inner_vscal1(n,d,x) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n real(psb_spk_), intent(in) :: d(*) real(psb_spk_), intent(inout) :: x(*) integer(psb_ipk_) :: i do i=1,n - x(i) = d(i)*x(i) + x(i) = d(i)*x(i) end do end subroutine inner_vscal1 end subroutine psb_s_base_cssv -subroutine psb_s_base_scals(d,a,info) +subroutine psb_s_base_scals(d,a,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scals use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1550,12 +1550,55 @@ subroutine psb_s_base_scals(d,a,info) end subroutine psb_s_base_scals +subroutine psb_s_base_scalplusidentity(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: acoo -subroutine psb_s_base_scal(d,a,info,side) + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_scalplusidentity + +subroutine psb_s_base_scal(d,a,info,side) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_scal use psb_error_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1581,7 +1624,7 @@ function psb_s_base_maxval(a) result(res) use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_maxval - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1608,27 +1651,27 @@ function psb_s_base_csnmi(a) result(res) use psb_realloc_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csnmi - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1646,27 +1689,27 @@ function psb_s_base_csnm1(a) result(res) use psb_realloc_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csnm1 - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1678,7 +1721,7 @@ function psb_s_base_csnm1(a) result(res) end function psb_s_base_csnm1 -subroutine psb_s_base_rowsum(d,a) +subroutine psb_s_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_rowsum @@ -1700,7 +1743,7 @@ subroutine psb_s_base_rowsum(d,a) end subroutine psb_s_base_rowsum -subroutine psb_s_base_arwsum(d,a) +subroutine psb_s_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_arwsum @@ -1722,7 +1765,7 @@ subroutine psb_s_base_arwsum(d,a) end subroutine psb_s_base_arwsum -subroutine psb_s_base_colsum(d,a) +subroutine psb_s_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_colsum @@ -1744,7 +1787,7 @@ subroutine psb_s_base_colsum(d,a) end subroutine psb_s_base_colsum -subroutine psb_s_base_aclsum(d,a) +subroutine psb_s_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_aclsum @@ -1766,12 +1809,12 @@ subroutine psb_s_base_aclsum(d,a) end subroutine psb_s_base_aclsum -subroutine psb_s_base_get_diag(a,d,info) +subroutine psb_s_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_get_diag - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1791,15 +1834,153 @@ subroutine psb_s_base_get_diag(a,d,info) end subroutine psb_s_base_get_diag +subroutine psb_s_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_spaxpby + + real(psb_spk_), intent(in) :: alpha + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: beta + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_s_base_spaxpby + +function psb_s_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cmpval + + class(psb_s_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_s_base_cmpval + +function psb_s_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cmpmat + + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_s_base_cmpmat ! == ================================== ! ! ! ! Computational routines for s_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! +! variables. If the actual data type is +! a "normal" one, these are sufficient. +! ! ! ! @@ -1807,11 +1988,11 @@ end subroutine psb_s_base_get_diag -subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_base_vect_mv - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x @@ -1820,7 +2001,7 @@ subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans ! For the time being we just throw everything back - ! onto the normal routines. + ! onto the normal routines. call x%sync() call y%sync() call a%spmm(alpha,x%v,beta,y%v,info,trans) @@ -1832,7 +2013,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_s_base_vect_mod use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x,y @@ -1869,54 +2050,54 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - call x%sync() + call x%sync() call y%sync() - if (present(d)) then + if (present(d)) then call d%sync() - if (present(scale)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(sone,d%v(1:nac),x,szero,info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call tmpv%mlt(sone,d%v(1:nac),x,szero,info) if (info == psb_success_)& & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - if (info == psb_success_) then + if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == szero) then + if (beta == szero) then call a%inner_spsm(alpha,x,szero,y,info,trans) if (info == psb_success_) call y%mlt(d%v(1:nar),info) else allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,szero,tmpv,info,trans) @@ -1925,7 +2106,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) & call y%axpby(nar,sone,tmpv,beta,info) if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1935,13 +2116,13 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1958,12 +2139,12 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_s_base_vect_cssv -subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_inner_vect_sv use psb_error_mod use psb_string_mod use psb_s_base_vect_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x, y @@ -1977,10 +2158,10 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) + call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1988,7 +2169,7 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return @@ -2000,7 +2181,7 @@ subroutine psb_s_base_cp_to_lcoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2009,22 +2190,22 @@ subroutine psb_s_base_cp_to_lcoo(a,b,info) character(len=20) :: name='to_lcoo' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_lcoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2038,7 +2219,7 @@ subroutine psb_s_base_cp_from_lcoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2047,22 +2228,22 @@ subroutine psb_s_base_cp_from_lcoo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_lcoo(b,info) + call tmp%cp_from_lcoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2076,7 +2257,7 @@ subroutine psb_s_base_cp_to_lfmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2086,10 +2267,10 @@ subroutine psb_s_base_cp_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: icoo type(psb_ls_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2102,12 +2283,12 @@ subroutine psb_s_base_cp_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2121,7 +2302,7 @@ subroutine psb_s_base_cp_from_lfmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2133,10 +2314,10 @@ subroutine psb_s_base_cp_from_lfmt(a,b,info) type(psb_ls_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_ls_coo_sparse_mat) call a%cp_from_lcoo(b,info) @@ -2146,8 +2327,8 @@ subroutine psb_s_base_cp_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2166,7 +2347,7 @@ subroutine psb_s_base_mv_to_lcoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2178,17 +2359,17 @@ subroutine psb_s_base_mv_to_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2202,7 +2383,7 @@ subroutine psb_s_base_mv_from_lcoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2213,17 +2394,17 @@ subroutine psb_s_base_mv_from_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2238,7 +2419,7 @@ subroutine psb_s_base_mv_to_lfmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2248,10 +2429,10 @@ subroutine psb_s_base_mv_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: icoo type(psb_ls_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2264,12 +2445,12 @@ subroutine psb_s_base_mv_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2283,7 +2464,7 @@ subroutine psb_s_base_mv_from_lfmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2295,10 +2476,10 @@ subroutine psb_s_base_mv_from_lfmt(a,b,info) type(psb_ls_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_ls_coo_sparse_mat) call a%mv_from_lcoo(b,info) @@ -2308,8 +2489,8 @@ subroutine psb_s_base_mv_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2343,7 +2524,7 @@ subroutine psb_ls_base_cp_to_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2367,7 +2548,7 @@ subroutine psb_ls_base_cp_from_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2392,7 +2573,7 @@ subroutine psb_ls_base_cp_to_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2401,10 +2582,10 @@ subroutine psb_ls_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_ls_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2415,12 +2596,12 @@ subroutine psb_ls_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2434,7 +2615,7 @@ subroutine psb_ls_base_cp_from_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2446,10 +2627,10 @@ subroutine psb_ls_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_ls_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -2458,8 +2639,8 @@ subroutine psb_ls_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2479,7 +2660,7 @@ subroutine psb_ls_base_mv_to_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2491,17 +2672,17 @@ subroutine psb_ls_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2516,7 +2697,7 @@ subroutine psb_ls_base_mv_from_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2527,17 +2708,17 @@ subroutine psb_ls_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2552,7 +2733,7 @@ subroutine psb_ls_base_mv_to_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2564,7 +2745,7 @@ subroutine psb_ls_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_ls_coo_sparse_mat) @@ -2582,7 +2763,7 @@ subroutine psb_ls_base_mv_from_fmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2594,7 +2775,7 @@ subroutine psb_ls_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_ls_coo_sparse_mat) @@ -2610,23 +2791,23 @@ end subroutine psb_ls_base_mv_from_fmt subroutine psb_ls_base_clean_zeros(a, info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clean_zeros - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_ls_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_ls_base_clean_zeros -subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -2647,11 +2828,11 @@ subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_ls_base_csput_a -subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v use psb_s_base_vect_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2664,10 +2845,10 @@ subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() @@ -2677,11 +2858,11 @@ subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2693,7 +2874,7 @@ end subroutine psb_ls_base_csput_v subroutine psb_ls_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetrow @@ -2733,7 +2914,7 @@ end subroutine psb_ls_base_csgetrow ! subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetblk @@ -2757,22 +2938,22 @@ subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -2787,19 +2968,19 @@ subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'ls_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -2827,7 +3008,7 @@ end subroutine psb_ls_base_csgetblk subroutine psb_ls_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csclip @@ -2849,46 +3030,46 @@ subroutine psb_ls_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -2917,7 +3098,7 @@ end subroutine psb_ls_base_csclip ! subroutine psb_ls_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_tril @@ -2929,9 +3110,9 @@ subroutine psb_ls_base_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ls_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_lpk_), allocatable :: ia(:), ja(:) real(psb_spk_), allocatable :: val(:) @@ -2943,51 +3124,51 @@ subroutine psb_ls_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -3019,7 +3200,7 @@ subroutine psb_ls_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -3027,8 +3208,8 @@ subroutine psb_ls_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -3041,7 +3222,7 @@ subroutine psb_ls_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -3050,8 +3231,8 @@ subroutine psb_ls_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -3069,7 +3250,7 @@ end subroutine psb_ls_base_tril subroutine psb_ls_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_triu @@ -3081,7 +3262,7 @@ subroutine psb_ls_base_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ls_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -3095,57 +3276,57 @@ subroutine psb_ls_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -3178,13 +3359,13 @@ subroutine psb_ls_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -3192,7 +3373,7 @@ subroutine psb_ls_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -3201,8 +3382,8 @@ subroutine psb_ls_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -3223,46 +3404,46 @@ end subroutine psb_ls_base_triu subroutine psb_ls_base_clone(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_ls_base_clone subroutine psb_ls_base_make_nonunit(a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a type(psb_ls_coo_sparse_mat) :: tmp - + integer(psb_ipk_) :: info integer(psb_lpk_) :: i, j, m, n, nz, mnm - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -3279,10 +3460,10 @@ subroutine psb_ls_base_make_nonunit(a) end subroutine psb_ls_base_make_nonunit -subroutine psb_ls_base_mold(a,b,info) +subroutine psb_ls_base_mold(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mold use psb_error_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3304,7 +3485,7 @@ end subroutine psb_ls_base_mold subroutine psb_ls_base_transp_2mat(a,b) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3324,11 +3505,11 @@ subroutine psb_ls_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3340,7 +3521,7 @@ end subroutine psb_ls_base_transp_2mat subroutine psb_ls_base_transc_2mat(a,b) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_2mat - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3360,11 +3541,11 @@ subroutine psb_ls_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3376,7 +3557,7 @@ end subroutine psb_ls_base_transc_2mat subroutine psb_ls_base_transp_1mat(a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a @@ -3390,12 +3571,12 @@ subroutine psb_ls_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3407,7 +3588,7 @@ end subroutine psb_ls_base_transp_1mat subroutine psb_ls_base_transc_1mat(a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_1mat - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a @@ -3421,12 +3602,12 @@ subroutine psb_ls_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3436,10 +3617,10 @@ subroutine psb_ls_base_transc_1mat(a) end subroutine psb_ls_base_transc_1mat -subroutine psb_ls_base_scals(d,a,info) +subroutine psb_ls_base_scals(d,a,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scals use psb_error_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3459,10 +3640,55 @@ subroutine psb_ls_base_scals(d,a,info) end subroutine psb_ls_base_scals -subroutine psb_ls_base_scal(d,a,info,side) +subroutine psb_ls_base_scalplusidentity(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_scalplusidentity + +subroutine psb_ls_base_scal(d,a,info,side) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scal use psb_error_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3488,7 +3714,7 @@ function psb_ls_base_maxval(a) result(res) use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_maxval - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3514,27 +3740,27 @@ function psb_ls_base_csnmi(a) result(res) use psb_realloc_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnmi - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3551,27 +3777,27 @@ function psb_ls_base_csnm1(a) result(res) use psb_realloc_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnm1 - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_spk_), allocatable :: vt(:) - + real(psb_spk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = szero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3582,7 +3808,7 @@ function psb_ls_base_csnm1(a) result(res) end function psb_ls_base_csnm1 -subroutine psb_ls_base_rowsum(d,a) +subroutine psb_ls_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_rowsum @@ -3604,7 +3830,7 @@ subroutine psb_ls_base_rowsum(d,a) end subroutine psb_ls_base_rowsum -subroutine psb_ls_base_arwsum(d,a) +subroutine psb_ls_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_arwsum @@ -3626,7 +3852,7 @@ subroutine psb_ls_base_arwsum(d,a) end subroutine psb_ls_base_arwsum -subroutine psb_ls_base_colsum(d,a) +subroutine psb_ls_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_colsum @@ -3648,7 +3874,7 @@ subroutine psb_ls_base_colsum(d,a) end subroutine psb_ls_base_colsum -subroutine psb_ls_base_aclsum(d,a) +subroutine psb_ls_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_aclsum @@ -3670,12 +3896,151 @@ subroutine psb_ls_base_aclsum(d,a) end subroutine psb_ls_base_aclsum -subroutine psb_ls_base_get_diag(a,d,info) +subroutine psb_ls_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_spaxpby + + real(psb_spk_), intent(in) :: alpha + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: beta + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ls_base_spaxpby + +function psb_ls_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cmpval + + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ls_base_cmpval + +function psb_ls_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cmpmat + + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ls_base_cmpmat + +subroutine psb_ls_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_get_diag - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3701,7 +4066,7 @@ subroutine psb_ls_base_cp_to_icoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3710,22 +4075,22 @@ subroutine psb_ls_base_cp_to_icoo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. type(psb_ls_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3739,7 +4104,7 @@ subroutine psb_ls_base_cp_from_icoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3748,22 +4113,22 @@ subroutine psb_ls_base_cp_from_icoo(a,b,info) character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. type(psb_ls_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_icoo(b,info) + call tmp%cp_from_icoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3778,7 +4143,7 @@ subroutine psb_ls_base_cp_to_ifmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3788,10 +4153,10 @@ subroutine psb_ls_base_cp_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: icoo type(psb_ls_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3804,12 +4169,12 @@ subroutine psb_ls_base_cp_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3823,7 +4188,7 @@ subroutine psb_ls_base_cp_from_ifmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3835,10 +4200,10 @@ subroutine psb_ls_base_cp_from_ifmt(a,b,info) type(psb_ls_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_s_coo_sparse_mat) call a%cp_from_icoo(b,info) @@ -3848,8 +4213,8 @@ subroutine psb_ls_base_cp_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -3868,7 +4233,7 @@ subroutine psb_ls_base_mv_to_icoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3880,17 +4245,17 @@ subroutine psb_ls_base_mv_to_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -3905,7 +4270,7 @@ subroutine psb_ls_base_mv_from_icoo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3916,17 +4281,17 @@ subroutine psb_ls_base_mv_from_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -3942,7 +4307,7 @@ subroutine psb_ls_base_mv_to_ifmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3952,10 +4317,10 @@ subroutine psb_ls_base_mv_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: icoo type(psb_ls_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3968,12 +4333,12 @@ subroutine psb_ls_base_mv_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3987,7 +4352,7 @@ subroutine psb_ls_base_mv_from_ifmt(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_ls_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3999,10 +4364,10 @@ subroutine psb_ls_base_mv_from_ifmt(a,b,info) type(psb_ls_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_s_coo_sparse_mat) call a%mv_from_icoo(b,info) @@ -4012,8 +4377,8 @@ subroutine psb_ls_base_mv_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -4026,5 +4391,3 @@ subroutine psb_ls_base_mv_from_ifmt(a,b,info) return end subroutine psb_ls_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_s_coo_impl.F90 b/base/serial/impl/psb_s_coo_impl.F90 index fffc3bf4d..061fb9045 100644 --- a/base/serial/impl/psb_s_coo_impl.F90 +++ b/base/serial/impl/psb_s_coo_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! -subroutine psb_s_coo_get_diag(a,d,info) +! +! +subroutine psb_s_coo_get_diag(a,d,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -47,19 +47,19 @@ subroutine psb_s_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = sone + if (a%is_unit()) then + d(1:mnm) = sone else d(1:mnm) = szero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -74,12 +74,12 @@ subroutine psb_s_coo_get_diag(a,d,info) end subroutine psb_s_coo_get_diag -subroutine psb_s_coo_scal(d,a,info,side) +subroutine psb_s_coo_scal(d,a,info,side) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -88,44 +88,44 @@ subroutine psb_s_coo_scal(d,a,info,side) integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -143,11 +143,11 @@ subroutine psb_s_coo_scal(d,a,info,side) end subroutine psb_s_coo_scal -subroutine psb_s_coo_scals(d,a,info) +subroutine psb_s_coo_scals(d,a,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -160,13 +160,14 @@ subroutine psb_s_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if do i=1,a%get_nzeros() a%val(i) = a%val(i) * d enddo + call a%set_host() call psb_erractionrestore(err_act) @@ -178,12 +179,207 @@ subroutine psb_s_coo_scals(d,a,info) end subroutine psb_s_coo_scals +subroutine psb_s_coo_scalplusidentity(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info -subroutine psb_s_coo_reallocate_nz(nz,a) + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + sone + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_coo_scalplusidentity + +subroutine psb_s_coo_spaxpby(alpha,a,beta,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_coo_spaxpby' + type(psb_s_coo_sparse_mat) :: tcoo,bcoo + integer(psb_ipk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_s_coo_spaxpby + +function psb_s_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cmpval + + class(psb_s_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_s_coo_cmpval + +function psb_s_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cmpmat + + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_ipk_) :: nza, nzb, nzl, M, N + type(psb_s_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-sone)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_s_coo_cmpmat + +subroutine psb_s_coo_reallocate_nz(nz,a) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -197,7 +393,7 @@ subroutine psb_s_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -211,11 +407,11 @@ subroutine psb_s_coo_reallocate_nz(nz,a) end subroutine psb_s_coo_reallocate_nz -subroutine psb_s_coo_ensure_size(nz,a) +subroutine psb_s_coo_ensure_size(nz,a) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -229,7 +425,7 @@ subroutine psb_s_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -243,10 +439,10 @@ subroutine psb_s_coo_ensure_size(nz,a) end subroutine psb_s_coo_ensure_size -subroutine psb_s_coo_mold(a,b,info) +subroutine psb_s_coo_mold(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mold use psb_error_mod - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -255,16 +451,16 @@ subroutine psb_s_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_s_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -279,9 +475,9 @@ end subroutine psb_s_coo_mold subroutine psb_s_coo_reinit(a,clear) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -293,17 +489,17 @@ subroutine psb_s_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = szero call a%set_host() call a%set_upd() @@ -328,7 +524,7 @@ subroutine psb_s_coo_trim(a) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' @@ -342,7 +538,7 @@ subroutine psb_s_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -355,13 +551,13 @@ end subroutine psb_s_coo_trim subroutine psb_s_coo_clean_zeros(a, info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_clean_zeros - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -372,14 +568,14 @@ subroutine psb_s_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_s_coo_clean_zeros subroutine psb_s_coo_clean_negidx(a,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_clean_negidx - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -387,13 +583,13 @@ subroutine psb_s_coo_clean_negidx(a,info) integer(psb_ipk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_s_coo_clean_negidx -subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_clean_negidx_inner - implicit none + implicit none integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) @@ -402,24 +598,24 @@ subroutine psb_s_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_ipk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_s_coo_clean_negidx_inner -subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -429,22 +625,22 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -452,7 +648,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(izero) @@ -464,7 +660,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -479,10 +675,10 @@ end subroutine psb_s_coo_allocate_mnnz subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -490,12 +686,12 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -504,26 +700,26 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_s_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -538,7 +734,7 @@ end subroutine psb_s_coo_print function psb_s_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_nz_row + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_nz_row implicit none class(psb_s_coo_sparse_mat), intent(in) :: a @@ -547,39 +743,39 @@ function psb_s_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -587,12 +783,12 @@ function psb_s_coo_get_nz_row(idx,a) result(res) end function psb_s_coo_get_nz_row -subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cssm - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -611,14 +807,14 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif if (a%is_dev()) call a%sync() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -643,7 +839,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() if (alpha == szero) then @@ -659,15 +855,15 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == szero) then + if (beta == szero) then call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & m,nc,nnz,a%ia,a%ja,a%val,& & x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -697,11 +893,11 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none + & ia,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) real(psb_spk_), intent(in) :: val(*), x(ldx,*) @@ -719,7 +915,7 @@ contains end if - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if @@ -727,14 +923,14 @@ contains nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = szero - do + do if (j > nnz) exit if (ia(j) > i) exit acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) @@ -742,14 +938,14 @@ contains end do y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc(1:nc) = szero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j + 1 exit @@ -760,12 +956,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = szero - do + do i=nr, 1, -1 + acc(1:nc) = szero + do if (j < 1) exit if (ia(j) < i) exit acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) @@ -774,15 +970,15 @@ contains y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = szero - do + do i=nr, 1, -1 + acc(1:nc) = szero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j - 1 exit @@ -795,68 +991,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do @@ -864,68 +1060,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / (val(j)) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / (val(j)) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc) j = j + 1 end do end do @@ -940,12 +1136,12 @@ end subroutine psb_s_coo_cssm -subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cssv - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -969,7 +1165,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -989,7 +1185,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1009,20 +1205,20 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) return end if - if (beta == szero) then + if (beta == szero) then call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if do i = 1, m y(i) = alpha*y(i) end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 @@ -1031,7 +1227,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -1047,11 +1243,11 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none + & ia,ja,val,x,y,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nz,ia(*),ja(*) real(psb_spk_), intent(in) :: val(*), x(*) @@ -1062,21 +1258,21 @@ contains real(psb_spk_) :: acc info = psb_success_ - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc = szero - do + do if (j > nnz) exit if (ia(j) > i) exit acc = acc + val(j)*y(ja(j)) @@ -1084,14 +1280,14 @@ contains end do y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc = szero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j + 1 exit @@ -1102,12 +1298,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc = szero - do + do i=nr, 1, -1 + acc = szero + do if (j < 1) exit if (ia(j) < i) exit acc = acc + val(j)*y(ja(j)) @@ -1116,15 +1312,15 @@ contains y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc = szero - do + do i=nr, 1, -1 + acc = szero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j - 1 exit @@ -1137,68 +1333,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 + y(jc) = y(jc) - val(j)*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do @@ -1206,68 +1402,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc - j = j - 1 + y(jc) = y(jc) - (val(j))*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /(val(j)) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc + y(jc) = y(jc) - (val(j))*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc + y(jc) = y(jc) - (val(j))*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /(val(j)) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - (val(j))*acc + y(jc) = y(jc) - (val(j))*acc j = j + 1 end do end do @@ -1281,12 +1477,12 @@ contains end subroutine psb_s_coo_cssv -subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csmv - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) @@ -1305,7 +1501,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1323,7 +1519,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1354,8 +1550,8 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == szero) then do i = 1, min(m,n) y(i) = alpha*x(i) @@ -1364,7 +1560,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) y(i) = szero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i) = beta*y(i) + alpha*x(i) end do do i = min(m,n)+1, m @@ -1386,28 +1582,28 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) end if - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = szero - do - if (i>nnz) then + do + if (i>nnz) then y(ir) = y(ir) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir) = y(ir) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = szero endif acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == sone) then i = 1 @@ -1425,7 +1621,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - a%val(i)*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1435,7 +1631,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) end if !.....end testing on alpha - else if (ctra) then + else if (ctra) then if (alpha == sone) then i = 1 @@ -1453,7 +1649,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - (a%val(i))*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1475,12 +1671,12 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_s_coo_csmv -subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csmm - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1499,7 +1695,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1518,7 +1714,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1558,8 +1754,8 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == szero) then do i = 1, min(m,n) y(i,1:nc) = alpha*x(i,1:nc) @@ -1568,7 +1764,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) y(i,1:nc) = szero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) end do do i = min(m,n)+1, m @@ -1590,28 +1786,28 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) end if - if (.not.tra) then + if (.not.tra) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = szero - do - if (i>nnz) then + do + if (i>nnz) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = szero endif acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == sone) then i = 1 @@ -1629,7 +1825,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1657,7 +1853,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - (a%val(i))*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1681,7 +1877,7 @@ end subroutine psb_s_coo_csmm function psb_s_coo_maxval(a) result(res) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_maxval - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1691,13 +1887,13 @@ function psb_s_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1707,7 +1903,7 @@ end function psb_s_coo_maxval function psb_s_coo_csnmi(a) result(res) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csnmi - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1724,15 +1920,15 @@ function psb_s_coo_csnmi(a) result(res) res = szero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = szero - do while (i<=nnz) + res = szero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -1747,7 +1943,7 @@ function psb_s_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = sone else vt = szero @@ -1759,7 +1955,7 @@ function psb_s_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_s_coo_csnmi @@ -1768,7 +1964,7 @@ function psb_s_coo_csnm1(a) result(res) use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csnm1 - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1787,7 +1983,7 @@ function psb_s_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = sone else vt = szero @@ -1803,7 +1999,7 @@ function psb_s_coo_csnm1(a) result(res) end function psb_s_coo_csnm1 -subroutine psb_s_coo_rowsum(d,a) +subroutine psb_s_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_rowsum @@ -1823,13 +2019,13 @@ subroutine psb_s_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1843,7 +2039,7 @@ subroutine psb_s_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1851,7 +2047,7 @@ subroutine psb_s_coo_rowsum(d,a) end subroutine psb_s_coo_rowsum -subroutine psb_s_coo_arwsum(d,a) +subroutine psb_s_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_arwsum @@ -1870,13 +2066,13 @@ subroutine psb_s_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1889,7 +2085,7 @@ subroutine psb_s_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1897,7 +2093,7 @@ subroutine psb_s_coo_arwsum(d,a) end subroutine psb_s_coo_arwsum -subroutine psb_s_coo_colsum(d,a) +subroutine psb_s_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_colsum @@ -1916,13 +2112,13 @@ subroutine psb_s_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1936,7 +2132,7 @@ subroutine psb_s_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1944,7 +2140,7 @@ subroutine psb_s_coo_colsum(d,a) end subroutine psb_s_coo_colsum -subroutine psb_s_coo_aclsum(d,a) +subroutine psb_s_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_aclsum @@ -1963,14 +2159,14 @@ subroutine psb_s_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1981,10 +2177,10 @@ subroutine psb_s_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -2009,7 +2205,7 @@ end subroutine psb_s_coo_aclsum subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2026,7 +2222,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2054,22 +2250,22 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2078,12 +2274,12 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2127,19 +2323,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2154,13 +2350,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2178,31 +2374,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -2211,7 +2407,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -2219,8 +2415,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -2233,12 +2429,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2250,11 +2446,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2268,7 +2464,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -2277,12 +2473,12 @@ end subroutine psb_s_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2327,27 +2523,27 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2356,12 +2552,12 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2409,19 +2605,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2436,13 +2632,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2460,34 +2656,34 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -2495,10 +2691,10 @@ contains end if enddo call psb_s_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -2507,7 +2703,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -2516,27 +2712,27 @@ contains nrd = max(a%get_nrows(),1) nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then - k = 0 + + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - end if + end if end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -2544,14 +2740,14 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) @@ -2573,12 +2769,12 @@ contains end subroutine psb_s_coo_csgetrow -subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csput_a - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -2590,30 +2786,30 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) character(len=20) :: name='s_coo_csput_a_impl' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -2624,13 +2820,13 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -2641,22 +2837,22 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call s_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2677,7 +2873,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: ia(:),ja(:) @@ -2688,11 +2884,11 @@ contains integer(psb_ipk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -2708,7 +2904,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2726,13 +2922,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2744,18 +2940,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2767,7 +2963,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2781,18 +2977,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2804,7 +3000,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2826,10 +3022,10 @@ contains end subroutine psb_s_coo_csput_a -subroutine psb_s_cp_coo_to_coo(a,b,info) +subroutine psb_s_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_coo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2868,10 +3064,10 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) end subroutine psb_s_cp_coo_to_coo -subroutine psb_s_cp_coo_from_coo(a,b,info) +subroutine psb_s_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_coo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2914,10 +3110,10 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) end subroutine psb_s_cp_coo_from_coo -subroutine psb_s_cp_coo_to_fmt(a,b,info) +subroutine psb_s_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_fmt - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2946,10 +3142,10 @@ subroutine psb_s_cp_coo_to_fmt(a,b,info) end subroutine psb_s_cp_coo_to_fmt -subroutine psb_s_cp_coo_from_fmt(a,b,info) +subroutine psb_s_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_fmt - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2980,10 +3176,10 @@ subroutine psb_s_cp_coo_from_fmt(a,b,info) end subroutine psb_s_cp_coo_from_fmt -subroutine psb_s_mv_coo_to_coo(a,b,info) +subroutine psb_s_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_to_coo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3022,10 +3218,10 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) end subroutine psb_s_mv_coo_to_coo -subroutine psb_s_mv_coo_from_coo(a,b,info) +subroutine psb_s_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_from_coo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3066,10 +3262,10 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) end subroutine psb_s_mv_coo_from_coo -subroutine psb_s_mv_coo_to_fmt(a,b,info) +subroutine psb_s_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_to_fmt - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3098,10 +3294,10 @@ subroutine psb_s_mv_coo_to_fmt(a,b,info) end subroutine psb_s_mv_coo_to_fmt -subroutine psb_s_mv_coo_from_fmt(a,b,info) +subroutine psb_s_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_mv_coo_from_fmt - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3134,7 +3330,7 @@ end subroutine psb_s_mv_coo_from_fmt subroutine psb_s_coo_cp_from(a,b) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_cp_from - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat), intent(in) :: b @@ -3164,7 +3360,7 @@ end subroutine psb_s_coo_cp_from subroutine psb_s_coo_mv_from(a,b) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mv_from - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat), intent(inout) :: b @@ -3193,11 +3389,11 @@ end subroutine psb_s_coo_mv_from -subroutine psb_s_fix_coo(a,info,idir) +subroutine psb_s_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3218,17 +3414,17 @@ subroutine psb_s_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_s_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -3251,14 +3447,14 @@ end subroutine psb_s_fix_coo -subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) @@ -3283,14 +3479,14 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -3299,17 +3495,17 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - select case(idir_) - case(psb_row_major_) + select case(idir_) + + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -3319,15 +3515,15 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -3338,9 +3534,9 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -3348,7 +3544,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3358,87 +3554,87 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3450,7 +3646,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -3459,7 +3655,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3469,73 +3665,73 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3544,15 +3740,15 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. - ! + ! let's try in place. + ! call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) @@ -3580,52 +3776,52 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3638,7 +3834,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -3648,13 +3844,13 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -3668,10 +3864,10 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -3679,7 +3875,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3689,86 +3885,86 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3780,7 +3976,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -3788,7 +3984,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3797,73 +3993,73 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3874,7 +4070,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & @@ -3902,42 +4098,42 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -3945,8 +4141,8 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3965,7 +4161,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -3979,10 +4175,10 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_s_fix_coo_inner -subroutine psb_s_cp_coo_to_lcoo(a,b,info) +subroutine psb_s_cp_coo_to_lcoo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_lcoo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4022,10 +4218,10 @@ subroutine psb_s_cp_coo_to_lcoo(a,b,info) end subroutine psb_s_cp_coo_to_lcoo -subroutine psb_s_cp_coo_from_lcoo(a,b,info) +subroutine psb_s_cp_coo_from_lcoo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_lcoo - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -4073,11 +4269,11 @@ end subroutine psb_s_cp_coo_from_lcoo ! ! -subroutine psb_ls_coo_get_diag(a,d,info) +subroutine psb_ls_coo_get_diag(a,d,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4092,19 +4288,19 @@ subroutine psb_ls_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = sone + if (a%is_unit()) then + d(1:mnm) = sone else d(1:mnm) = szero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -4118,12 +4314,12 @@ subroutine psb_ls_coo_get_diag(a,d,info) end subroutine psb_ls_coo_get_diag -subroutine psb_ls_coo_scal(d,a,info,side) +subroutine psb_ls_coo_scal(d,a,info,side) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4133,44 +4329,44 @@ subroutine psb_ls_coo_scal(d,a,info,side) integer(psb_lpk_) :: mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -4188,11 +4384,11 @@ subroutine psb_ls_coo_scal(d,a,info,side) end subroutine psb_ls_coo_scal -subroutine psb_ls_coo_scals(d,a,info) +subroutine psb_ls_coo_scals(d,a,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4206,7 +4402,7 @@ subroutine psb_ls_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -4228,7 +4424,7 @@ end subroutine psb_ls_coo_scals function psb_ls_coo_maxval(a) result(res) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_maxval - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -4238,13 +4434,13 @@ function psb_ls_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -4254,7 +4450,7 @@ end function psb_ls_coo_maxval function psb_ls_coo_csnmi(a) result(res) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnmi - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -4271,15 +4467,15 @@ function psb_ls_coo_csnmi(a) result(res) res = szero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = szero - do while (i<=nnz) + res = szero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -4294,7 +4490,7 @@ function psb_ls_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = sone else vt = szero @@ -4306,7 +4502,7 @@ function psb_ls_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_ls_coo_csnmi @@ -4315,7 +4511,7 @@ function psb_ls_coo_csnm1(a) result(res) use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnm1 - implicit none + implicit none class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -4334,7 +4530,7 @@ function psb_ls_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = sone else vt = szero @@ -4350,7 +4546,7 @@ function psb_ls_coo_csnm1(a) result(res) end function psb_ls_coo_csnm1 -subroutine psb_ls_coo_rowsum(d,a) +subroutine psb_ls_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_rowsum @@ -4371,13 +4567,13 @@ subroutine psb_ls_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -4391,7 +4587,7 @@ subroutine psb_ls_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4399,7 +4595,7 @@ subroutine psb_ls_coo_rowsum(d,a) end subroutine psb_ls_coo_rowsum -subroutine psb_ls_coo_arwsum(d,a) +subroutine psb_ls_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_arwsum @@ -4419,13 +4615,13 @@ subroutine psb_ls_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -4438,7 +4634,7 @@ subroutine psb_ls_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4446,7 +4642,7 @@ subroutine psb_ls_coo_arwsum(d,a) end subroutine psb_ls_coo_arwsum -subroutine psb_ls_coo_colsum(d,a) +subroutine psb_ls_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_colsum @@ -4466,13 +4662,13 @@ subroutine psb_ls_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -4486,7 +4682,7 @@ subroutine psb_ls_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4494,7 +4690,7 @@ subroutine psb_ls_coo_colsum(d,a) end subroutine psb_ls_coo_colsum -subroutine psb_ls_coo_aclsum(d,a) +subroutine psb_ls_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_aclsum @@ -4514,14 +4710,14 @@ subroutine psb_ls_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -4532,10 +4728,10 @@ subroutine psb_ls_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4543,11 +4739,207 @@ subroutine psb_ls_coo_aclsum(d,a) end subroutine psb_ls_coo_aclsum -subroutine psb_ls_coo_reallocate_nz(nz,a) +subroutine psb_ls_coo_scalplusidentity(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + sone + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_scalplusidentity + +subroutine psb_ls_coo_spaxpby(alpha,a,beta,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: alpha + real(psb_spk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_spaxpby' + type(psb_ls_coo_sparse_mat) :: tcoo,bcoo + integer(psb_lpk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ls_coo_spaxpby + +function psb_ls_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cmpval + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ls_coo_cmpval + +function psb_ls_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cmpmat + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_lpk_) :: nza, nzb, nzl, M, N + type(psb_ls_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-1_psb_spk_)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_ls_coo_cmpmat + +subroutine psb_ls_coo_reallocate_nz(nz,a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4562,7 +4954,7 @@ subroutine psb_ls_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4576,11 +4968,11 @@ subroutine psb_ls_coo_reallocate_nz(nz,a) end subroutine psb_ls_coo_reallocate_nz -subroutine psb_ls_coo_ensure_size(nz,a) +subroutine psb_ls_coo_ensure_size(nz,a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -4594,7 +4986,7 @@ subroutine psb_ls_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4608,10 +5000,10 @@ subroutine psb_ls_coo_ensure_size(nz,a) end subroutine psb_ls_coo_ensure_size -subroutine psb_ls_coo_mold(a,b,info) +subroutine psb_ls_coo_mold(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mold use psb_error_mod - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4620,16 +5012,16 @@ subroutine psb_ls_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_ls_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4644,9 +5036,9 @@ end subroutine psb_ls_coo_mold subroutine psb_ls_coo_reinit(a,clear) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4658,17 +5050,17 @@ subroutine psb_ls_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = szero call a%set_host() call a%set_upd() @@ -4693,7 +5085,7 @@ subroutine psb_ls_coo_trim(a) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info integer(psb_lpk_) :: nz @@ -4708,7 +5100,7 @@ subroutine psb_ls_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4721,13 +5113,13 @@ end subroutine psb_ls_coo_trim subroutine psb_ls_coo_clean_zeros(a, info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_zeros - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -4738,14 +5130,14 @@ subroutine psb_ls_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_ls_coo_clean_zeros subroutine psb_ls_coo_clean_negidx(a,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_negidx - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -4753,14 +5145,14 @@ subroutine psb_ls_coo_clean_negidx(a,info) integer(psb_lpk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_ls_coo_clean_negidx -#if defined(IPK4) && defined(LPK8) -subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +#if defined(IPK4) && defined(LPK8) +subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_negidx_inner - implicit none + implicit none integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) @@ -4769,25 +5161,25 @@ subroutine psb_ls_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_lpk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_ls_coo_clean_negidx_inner #endif -subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4798,22 +5190,22 @@ subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -4821,7 +5213,7 @@ subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(lzero) @@ -4833,7 +5225,7 @@ subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4848,10 +5240,10 @@ end subroutine psb_ls_coo_allocate_mnnz subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4864,8 +5256,8 @@ subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_lpk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4874,26 +5266,26 @@ subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_ls_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -4908,7 +5300,7 @@ end subroutine psb_ls_coo_print function psb_ls_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_nz_row + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_nz_row implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a @@ -4918,40 +5310,40 @@ function psb_ls_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: inza if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. inza = nza ip = psb_bsrch(idx,inza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -4975,7 +5367,7 @@ end function psb_ls_coo_get_nz_row subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4992,7 +5384,7 @@ subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5021,22 +5413,22 @@ subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5045,12 +5437,12 @@ subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5095,19 +5487,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5122,13 +5514,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5146,31 +5538,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -5179,7 +5571,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -5187,8 +5579,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -5201,12 +5593,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5218,11 +5610,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5236,7 +5628,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -5245,12 +5637,12 @@ end subroutine psb_ls_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -5268,7 +5660,7 @@ subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5296,22 +5688,22 @@ subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5320,12 +5712,12 @@ subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5374,19 +5766,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5401,13 +5793,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5425,32 +5817,32 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -5458,10 +5850,10 @@ contains end if enddo call psb_ls_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -5470,7 +5862,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -5484,12 +5876,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5503,11 +5895,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5531,12 +5923,12 @@ contains end subroutine psb_ls_coo_csgetrow -subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csput_a - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -5549,30 +5941,30 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) logical, parameter :: debug=.false. integer(psb_lpk_) :: nza, i,j,k, nzl, isza integer(psb_ipk_) :: debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -5583,13 +5975,13 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -5600,22 +5992,22 @@ subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call ls_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -5636,7 +6028,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: ia(:),ja(:) @@ -5647,11 +6039,11 @@ contains integer(psb_lpk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -5667,7 +6059,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -5685,13 +6077,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() innz = nnz @@ -5702,18 +6094,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5725,7 +6117,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -5739,18 +6131,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5762,7 +6154,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -5784,10 +6176,10 @@ contains end subroutine psb_ls_coo_csput_a -subroutine psb_ls_cp_coo_to_coo(a,b,info) +subroutine psb_ls_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_coo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5827,10 +6219,10 @@ subroutine psb_ls_cp_coo_to_coo(a,b,info) end subroutine psb_ls_cp_coo_to_coo -subroutine psb_ls_cp_coo_from_coo(a,b,info) +subroutine psb_ls_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_coo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5873,10 +6265,10 @@ subroutine psb_ls_cp_coo_from_coo(a,b,info) end subroutine psb_ls_cp_coo_from_coo -subroutine psb_ls_cp_coo_to_fmt(a,b,info) +subroutine psb_ls_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_fmt - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5905,10 +6297,10 @@ subroutine psb_ls_cp_coo_to_fmt(a,b,info) end subroutine psb_ls_cp_coo_to_fmt -subroutine psb_ls_cp_coo_from_fmt(a,b,info) +subroutine psb_ls_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_fmt - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5939,10 +6331,10 @@ subroutine psb_ls_cp_coo_from_fmt(a,b,info) end subroutine psb_ls_cp_coo_from_fmt -subroutine psb_ls_mv_coo_to_coo(a,b,info) +subroutine psb_ls_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_coo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5981,10 +6373,10 @@ subroutine psb_ls_mv_coo_to_coo(a,b,info) end subroutine psb_ls_mv_coo_to_coo -subroutine psb_ls_mv_coo_from_coo(a,b,info) +subroutine psb_ls_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_coo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6025,10 +6417,10 @@ subroutine psb_ls_mv_coo_from_coo(a,b,info) end subroutine psb_ls_mv_coo_from_coo -subroutine psb_ls_mv_coo_to_fmt(a,b,info) +subroutine psb_ls_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_fmt - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6057,10 +6449,10 @@ subroutine psb_ls_mv_coo_to_fmt(a,b,info) end subroutine psb_ls_mv_coo_to_fmt -subroutine psb_ls_mv_coo_from_fmt(a,b,info) +subroutine psb_ls_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_fmt - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6093,7 +6485,7 @@ end subroutine psb_ls_mv_coo_from_fmt subroutine psb_ls_coo_cp_from(a,b) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cp_from - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a type(psb_ls_coo_sparse_mat), intent(in) :: b @@ -6123,7 +6515,7 @@ end subroutine psb_ls_coo_cp_from subroutine psb_ls_coo_mv_from(a,b) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mv_from - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a type(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -6152,11 +6544,11 @@ end subroutine psb_ls_coo_mv_from -subroutine psb_ls_fix_coo(a,info,idir) +subroutine psb_ls_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -6177,17 +6569,17 @@ subroutine psb_ls_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_ls_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -6210,14 +6602,14 @@ end subroutine psb_ls_fix_coo -subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -6244,14 +6636,14 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -6260,16 +6652,16 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - select case(idir_) + select case(idir_) - case(psb_row_major_) + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -6277,17 +6669,17 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = (info == 0) else use_buffers = .false. - end if - - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + end if + + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -6298,9 +6690,9 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -6308,7 +6700,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6318,87 +6710,87 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6410,7 +6802,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -6419,7 +6811,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6429,73 +6821,73 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6504,14 +6896,14 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. + ! let's try in place. ! inzin = nzin call psi_msort_up(inzin,ia(1:),iaux(1:),iret) @@ -6541,52 +6933,52 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6599,7 +6991,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -6609,13 +7001,13 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -6629,10 +7021,10 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -6640,7 +7032,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6650,86 +7042,86 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6741,7 +7133,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -6749,7 +7141,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6758,73 +7150,73 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6835,7 +7227,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then inzin = nzin call psi_msort_up(inzin,ja(1:),iaux(1:),iret) @@ -6864,42 +7256,42 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -6907,8 +7299,8 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6927,7 +7319,7 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -6941,10 +7333,10 @@ subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_ls_fix_coo_inner -subroutine psb_ls_cp_coo_to_icoo(a,b,info) +subroutine psb_ls_cp_coo_to_icoo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_icoo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6984,10 +7376,10 @@ subroutine psb_ls_cp_coo_to_icoo(a,b,info) end subroutine psb_ls_cp_coo_to_icoo -subroutine psb_ls_cp_coo_from_icoo(a,b,info) +subroutine psb_ls_cp_coo_from_icoo(a,b,info) use psb_error_mod use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_icoo - implicit none + implicit none class(psb_ls_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -7027,4 +7419,3 @@ subroutine psb_ls_cp_coo_from_icoo(a,b,info) return end subroutine psb_ls_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index ffa84d411..71e240513 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csmv - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -72,7 +72,7 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -81,7 +81,7 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) if (a%is_dev()) call a%sync() - if (size(x,1) psb_s_csc_csmm - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -350,13 +350,13 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) end if tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -364,16 +364,16 @@ subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_s_csc_cssv - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -632,7 +632,7 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -642,28 +642,28 @@ subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x,1) psb_s_csc_cssm - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -852,7 +852,7 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -862,23 +862,23 @@ subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (size(x,1) psb_s_csc_maxval - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1066,7 +1066,7 @@ function psb_s_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero @@ -1074,7 +1074,7 @@ function psb_s_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1085,7 +1085,7 @@ function psb_s_csc_csnm1(a) result(res) use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csnm1 - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1099,13 +1099,13 @@ function psb_s_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = szero + res = szero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -1115,12 +1115,12 @@ function psb_s_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_s_csc_csnm1 -subroutine psb_s_csc_colsum(d,a) +subroutine psb_s_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_colsum @@ -1140,7 +1140,7 @@ subroutine psb_s_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1148,19 +1148,19 @@ subroutine psb_s_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = sone else d(i) = szero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1168,7 +1168,7 @@ subroutine psb_s_csc_colsum(d,a) end subroutine psb_s_csc_colsum -subroutine psb_s_csc_aclsum(d,a) +subroutine psb_s_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_aclsum @@ -1188,7 +1188,7 @@ subroutine psb_s_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1197,25 +1197,25 @@ subroutine psb_s_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = sone else d(i) = szero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1223,7 +1223,7 @@ subroutine psb_s_csc_aclsum(d,a) end subroutine psb_s_csc_aclsum -subroutine psb_s_csc_rowsum(d,a) +subroutine psb_s_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_rowsum @@ -1244,14 +1244,14 @@ subroutine psb_s_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1265,7 +1265,7 @@ subroutine psb_s_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1273,7 +1273,7 @@ subroutine psb_s_csc_rowsum(d,a) end subroutine psb_s_csc_rowsum -subroutine psb_s_csc_arwsum(d,a) +subroutine psb_s_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_arwsum @@ -1294,14 +1294,14 @@ subroutine psb_s_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -1315,7 +1315,7 @@ subroutine psb_s_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1324,11 +1324,11 @@ subroutine psb_s_csc_arwsum(d,a) end subroutine psb_s_csc_arwsum -subroutine psb_s_csc_get_diag(a,d,info) +subroutine psb_s_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_get_diag - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1343,28 +1343,28 @@ subroutine psb_s_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = sone + if (a%is_unit()) then + d(1:mnm) = sone else do i=1, mnm d(i) = szero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = szero end do call psb_erractionrestore(err_act) @@ -1377,12 +1377,12 @@ subroutine psb_s_csc_get_diag(a,d,info) end subroutine psb_s_csc_get_diag -subroutine psb_s_csc_scal(d,a,info,side) +subroutine psb_s_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scal use psb_string_mod - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1393,7 +1393,7 @@ subroutine psb_s_csc_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -1401,39 +1401,39 @@ subroutine psb_s_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -1449,11 +1449,11 @@ subroutine psb_s_csc_scal(d,a,info,side) end subroutine psb_s_csc_scal -subroutine psb_s_csc_scals(d,a,info) +subroutine psb_s_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_scals - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1467,7 +1467,7 @@ subroutine psb_s_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1486,7 +1486,7 @@ subroutine psb_s_csc_scals(d,a,info) end subroutine psb_s_csc_scals -! == =================================== +! == =================================== ! ! ! @@ -1496,11 +1496,11 @@ end subroutine psb_s_csc_scals ! ! ! -! == =================================== +! == =================================== subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1518,7 +1518,7 @@ subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1547,35 +1547,35 @@ subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1621,12 +1621,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1637,19 +1637,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1663,9 +1663,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1677,9 +1677,9 @@ contains enddo end do end if - + end subroutine csc_getptn - + end subroutine psb_s_csc_csgetptn @@ -1687,7 +1687,7 @@ end subroutine psb_s_csc_csgetptn subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1706,7 +1706,7 @@ subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1716,7 +1716,7 @@ subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1736,22 +1736,22 @@ subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -1759,13 +1759,13 @@ subroutine psb_s_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1813,12 +1813,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1829,7 +1829,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -1837,12 +1837,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1858,9 +1858,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1880,11 +1880,11 @@ end subroutine psb_s_csc_csgetrow -subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput_a - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -1903,26 +1903,26 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -1933,25 +1933,25 @@ subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_s_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -1977,7 +1977,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -1995,13 +1995,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -2011,19 +2011,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2036,18 +2036,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2070,12 +2070,12 @@ end subroutine psb_s_csc_csput_a -subroutine psb_s_cp_csc_from_coo(a,b,info) +subroutine psb_s_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_from_coo - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b @@ -2098,11 +2098,11 @@ end subroutine psb_s_cp_csc_from_coo -subroutine psb_s_cp_csc_to_coo(a,b,info) +subroutine psb_s_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_to_coo - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b @@ -2132,7 +2132,7 @@ subroutine psb_s_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -2140,12 +2140,12 @@ subroutine psb_s_cp_csc_to_coo(a,b,info) end subroutine psb_s_cp_csc_to_coo -subroutine psb_s_mv_csc_to_coo(a,b,info) +subroutine psb_s_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_to_coo - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b @@ -2183,13 +2183,13 @@ end subroutine psb_s_mv_csc_to_coo -subroutine psb_s_mv_csc_from_coo(a,b,info) +subroutine psb_s_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_coo - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b @@ -2213,7 +2213,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -2236,17 +2236,17 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_s_mv_csc_from_coo -subroutine psb_s_mv_csc_to_fmt(a,b,info) +subroutine psb_s_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_to_fmt - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b @@ -2262,10 +2262,10 @@ subroutine psb_s_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_s_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_s_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -2282,12 +2282,12 @@ subroutine psb_s_mv_csc_to_fmt(a,b,info) end subroutine psb_s_mv_csc_to_fmt !!$ -subroutine psb_s_cp_csc_to_fmt(a,b,info) +subroutine psb_s_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_to_fmt - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b @@ -2303,10 +2303,10 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_s_csc_sparse_mat) + type is (psb_s_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat nc = a%get_ncols() @@ -2324,12 +2324,12 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info) end subroutine psb_s_cp_csc_to_fmt -subroutine psb_s_mv_csc_from_fmt(a,b,info) +subroutine psb_s_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_mv_csc_from_fmt - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b @@ -2345,10 +2345,10 @@ subroutine psb_s_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_s_csc_sparse_mat) + type is (psb_s_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat @@ -2369,19 +2369,19 @@ end subroutine psb_s_mv_csc_from_fmt subroutine psb_s_csc_clean_zeros(a, info) use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_clean_zeros - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nc - integer(psb_ipk_), allocatable :: ilcp(:) - + integer(psb_ipk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= szero) then @@ -2396,12 +2396,12 @@ subroutine psb_s_csc_clean_zeros(a, info) call a%set_host() end subroutine psb_s_csc_clean_zeros -subroutine psb_s_cp_csc_from_fmt(a,b,info) +subroutine psb_s_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_cp_csc_from_fmt - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b @@ -2417,10 +2417,10 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_s_csc_sparse_mat) + type is (psb_s_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat nc = b%get_ncols() @@ -2435,14 +2435,14 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_s_cp_csc_from_fmt -subroutine psb_s_csc_mold(a,b,info) +subroutine psb_s_csc_mold(a,b,info) use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mold use psb_error_mod - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2452,16 +2452,16 @@ subroutine psb_s_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_s_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -2473,11 +2473,11 @@ subroutine psb_s_csc_mold(a,b,info) end subroutine psb_s_csc_mold -subroutine psb_s_csc_reallocate_nz(nz,a) +subroutine psb_s_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -2490,7 +2490,7 @@ subroutine psb_s_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -2508,7 +2508,7 @@ end subroutine psb_s_csc_reallocate_nz !!$subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& !!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ ! Output is always in COO format +!!$ ! Output is always in COO format !!$ use psb_error_mod !!$ use psb_const_mod !!$ use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csgetblk @@ -2531,12 +2531,12 @@ end subroutine psb_s_csc_reallocate_nz !!$ call psb_erractionsave(err_act) !!$ info = psb_success_ !!$ -!!$ if (present(append)) then +!!$ if (present(append)) then !!$ append_ = append !!$ else !!$ append_ = .false. !!$ endif -!!$ if (append_) then +!!$ if (append_) then !!$ nzin = a%get_nzeros() !!$ else !!$ nzin = 0 @@ -2564,9 +2564,9 @@ end subroutine psb_s_csc_reallocate_nz subroutine psb_s_csc_reinit(a,clear) use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_reinit - implicit none + implicit none - class(psb_s_csc_sparse_mat), intent(inout) :: a + class(psb_s_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2580,16 +2580,16 @@ subroutine psb_s_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = szero call a%set_upd() call a%set_host() @@ -2612,7 +2612,7 @@ subroutine psb_s_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_trim - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, n integer(psb_ipk_) :: ierr(5) @@ -2627,7 +2627,7 @@ subroutine psb_s_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2637,11 +2637,11 @@ subroutine psb_s_csc_trim(a) end subroutine psb_s_csc_trim -subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -2652,26 +2652,26 @@ subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -2679,7 +2679,7 @@ subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -2702,25 +2702,27 @@ end subroutine psb_s_csc_allocate_mnnz subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_csc_print' logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='real' character(len=80) :: frmt - integer(psb_ipk_) :: i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2729,35 +2731,35 @@ subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_s_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -2770,7 +2772,7 @@ subroutine psb_scscspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_scscspspmm - implicit none + implicit none class(psb_s_csc_sparse_mat), intent(in) :: a,b type(psb_s_csc_sparse_mat), intent(out) :: c @@ -2790,7 +2792,7 @@ subroutine psb_scscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -2819,9 +2821,9 @@ subroutine psb_scscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_s_csc_sparse_mat), intent(in) :: a,b type(psb_s_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -2844,29 +2846,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -2874,11 +2876,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do @@ -2891,11 +2893,11 @@ end subroutine psb_scscspspmm -subroutine psb_ls_csc_get_diag(a,d,info) +subroutine psb_ls_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_get_diag - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2910,28 +2912,28 @@ subroutine psb_ls_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = sone + if (a%is_unit()) then + d(1:mnm) = sone else do i=1, mnm d(i) = szero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = szero end do call psb_erractionrestore(err_act) @@ -2944,12 +2946,12 @@ subroutine psb_ls_csc_get_diag(a,d,info) end subroutine psb_ls_csc_get_diag -subroutine psb_ls_csc_scal(d,a,info,side) +subroutine psb_ls_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_scal use psb_string_mod - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2960,7 +2962,7 @@ subroutine psb_ls_csc_scal(d,a,info,side) integer(psb_ipk_) :: err_act,ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -2968,39 +2970,39 @@ subroutine psb_ls_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -3016,11 +3018,11 @@ subroutine psb_ls_csc_scal(d,a,info,side) end subroutine psb_ls_csc_scal -subroutine psb_ls_csc_scals(d,a,info) +subroutine psb_ls_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_scals - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3034,7 +3036,7 @@ subroutine psb_ls_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3056,7 +3058,7 @@ end subroutine psb_ls_csc_scals function psb_ls_csc_maxval(a) result(res) use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_maxval - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3065,7 +3067,7 @@ function psb_ls_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = sone else res = szero @@ -3073,7 +3075,7 @@ function psb_ls_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3084,7 +3086,7 @@ function psb_ls_csc_csnm1(a) result(res) use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csnm1 - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3097,13 +3099,13 @@ function psb_ls_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = szero + res = szero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = sone else acc = szero @@ -3113,12 +3115,12 @@ function psb_ls_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_ls_csc_csnm1 -subroutine psb_ls_csc_colsum(d,a) +subroutine psb_ls_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_colsum @@ -3139,7 +3141,7 @@ subroutine psb_ls_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3147,19 +3149,19 @@ subroutine psb_ls_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = sone else d(i) = szero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3167,7 +3169,7 @@ subroutine psb_ls_csc_colsum(d,a) end subroutine psb_ls_csc_colsum -subroutine psb_ls_csc_aclsum(d,a) +subroutine psb_ls_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_aclsum @@ -3188,7 +3190,7 @@ subroutine psb_ls_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3197,25 +3199,25 @@ subroutine psb_ls_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = sone else d(i) = szero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3223,7 +3225,7 @@ subroutine psb_ls_csc_aclsum(d,a) end subroutine psb_ls_csc_aclsum -subroutine psb_ls_csc_rowsum(d,a) +subroutine psb_ls_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_rowsum @@ -3231,7 +3233,7 @@ subroutine psb_ls_csc_rowsum(d,a) real(psb_spk_), intent(out) :: d(:) integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc - integer(psb_epk_) :: m,n + integer(psb_epk_) :: m,n real(psb_spk_) :: acc real(psb_spk_), allocatable :: vt(:) logical :: tra @@ -3245,14 +3247,14 @@ subroutine psb_ls_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -3266,7 +3268,7 @@ subroutine psb_ls_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3274,7 +3276,7 @@ subroutine psb_ls_csc_rowsum(d,a) end subroutine psb_ls_csc_rowsum -subroutine psb_ls_csc_arwsum(d,a) +subroutine psb_ls_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_arwsum @@ -3296,14 +3298,14 @@ subroutine psb_ls_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = sone else d = szero @@ -3317,7 +3319,7 @@ subroutine psb_ls_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3326,7 +3328,7 @@ subroutine psb_ls_csc_arwsum(d,a) end subroutine psb_ls_csc_arwsum -! == =================================== +! == =================================== ! ! ! @@ -3336,11 +3338,11 @@ end subroutine psb_ls_csc_arwsum ! ! ! -! == =================================== +! == =================================== subroutine psb_ls_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3358,7 +3360,7 @@ subroutine psb_ls_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3387,35 +3389,35 @@ subroutine psb_ls_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call lcsc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3461,12 +3463,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3477,19 +3479,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3503,9 +3505,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3517,9 +3519,9 @@ contains enddo end do end if - + end subroutine lcsc_getptn - + end subroutine psb_ls_csc_csgetptn @@ -3527,7 +3529,7 @@ end subroutine psb_ls_csc_csgetptn subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3546,7 +3548,7 @@ subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3556,7 +3558,7 @@ subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -3576,22 +3578,22 @@ subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -3599,13 +3601,13 @@ subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call lcsc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3653,12 +3655,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3669,7 +3671,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -3677,12 +3679,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3698,9 +3700,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3720,11 +3722,11 @@ end subroutine psb_ls_csc_csgetrow -subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csput_a - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -3743,26 +3745,26 @@ subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -3773,25 +3775,25 @@ subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_ls_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -3817,7 +3819,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -3835,13 +3837,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -3851,19 +3853,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -3876,18 +3878,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -3909,12 +3911,12 @@ contains end subroutine psb_ls_csc_csput_a -subroutine psb_ls_cp_csc_from_coo(a,b,info) +subroutine psb_ls_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_from_coo - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b @@ -3937,11 +3939,11 @@ end subroutine psb_ls_cp_csc_from_coo -subroutine psb_ls_cp_csc_to_coo(a,b,info) +subroutine psb_ls_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_to_coo - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -3971,7 +3973,7 @@ subroutine psb_ls_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -3979,12 +3981,12 @@ subroutine psb_ls_cp_csc_to_coo(a,b,info) end subroutine psb_ls_cp_csc_to_coo -subroutine psb_ls_mv_csc_to_coo(a,b,info) +subroutine psb_ls_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_to_coo - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -4021,13 +4023,13 @@ subroutine psb_ls_mv_csc_to_coo(a,b,info) end subroutine psb_ls_mv_csc_to_coo -subroutine psb_ls_mv_csc_from_coo(a,b,info) +subroutine psb_ls_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_from_coo - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -4051,7 +4053,7 @@ subroutine psb_ls_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -4074,17 +4076,17 @@ subroutine psb_ls_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_ls_mv_csc_from_coo -subroutine psb_ls_mv_csc_to_fmt(a,b,info) +subroutine psb_ls_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_to_fmt - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b @@ -4100,10 +4102,10 @@ subroutine psb_ls_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_ls_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_ls_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -4120,12 +4122,12 @@ subroutine psb_ls_mv_csc_to_fmt(a,b,info) end subroutine psb_ls_mv_csc_to_fmt !!$ -subroutine psb_ls_cp_csc_to_fmt(a,b,info) +subroutine psb_ls_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_to_fmt - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b @@ -4141,10 +4143,10 @@ subroutine psb_ls_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_ls_csc_sparse_mat) + type is (psb_ls_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat nc = a%get_ncols() @@ -4162,12 +4164,12 @@ subroutine psb_ls_cp_csc_to_fmt(a,b,info) end subroutine psb_ls_cp_csc_to_fmt -subroutine psb_ls_mv_csc_from_fmt(a,b,info) +subroutine psb_ls_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_from_fmt - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b @@ -4183,10 +4185,10 @@ subroutine psb_ls_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_ls_csc_sparse_mat) + type is (psb_ls_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat @@ -4206,12 +4208,12 @@ end subroutine psb_ls_mv_csc_from_fmt -subroutine psb_ls_cp_csc_from_fmt(a,b,info) +subroutine psb_ls_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_from_fmt - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b @@ -4227,10 +4229,10 @@ subroutine psb_ls_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_ls_csc_sparse_mat) + type is (psb_ls_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat nc = b%get_ncols() @@ -4245,25 +4247,25 @@ subroutine psb_ls_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_ls_cp_csc_from_fmt subroutine psb_ls_csc_clean_zeros(a, info) use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_clean_zeros - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nc - integer(psb_lpk_), allocatable :: ilcp(:) - + integer(psb_lpk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= szero) then @@ -4279,10 +4281,10 @@ subroutine psb_ls_csc_clean_zeros(a, info) end subroutine psb_ls_csc_clean_zeros -subroutine psb_ls_csc_mold(a,b,info) +subroutine psb_ls_csc_mold(a,b,info) use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_mold use psb_error_mod - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4291,16 +4293,16 @@ subroutine psb_ls_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_ls_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4312,11 +4314,11 @@ subroutine psb_ls_csc_mold(a,b,info) end subroutine psb_ls_csc_mold -subroutine psb_ls_csc_reallocate_nz(nz,a) +subroutine psb_ls_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4328,7 +4330,7 @@ subroutine psb_ls_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4346,7 +4348,7 @@ end subroutine psb_ls_csc_reallocate_nz subroutine psb_ls_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csgetblk @@ -4369,12 +4371,12 @@ subroutine psb_ls_csc_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 @@ -4402,9 +4404,9 @@ end subroutine psb_ls_csc_csgetblk subroutine psb_ls_csc_reinit(a,clear) use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_reinit - implicit none + implicit none - class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4418,16 +4420,16 @@ subroutine psb_ls_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = szero call a%set_upd() call a%set_host() @@ -4450,7 +4452,7 @@ subroutine psb_ls_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_trim - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, n integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4465,7 +4467,7 @@ subroutine psb_ls_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4475,11 +4477,11 @@ subroutine psb_ls_csc_trim(a) end subroutine psb_ls_csc_trim -subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_ls_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4490,26 +4492,26 @@ subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -4517,7 +4519,7 @@ subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -4540,24 +4542,25 @@ end subroutine psb_ls_csc_allocate_mnnz subroutine psb_ls_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='ls_csc_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4566,36 +4569,36 @@ subroutine psb_ls_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_ls_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -4608,7 +4611,7 @@ subroutine psb_lscscspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_lscscspspmm - implicit none + implicit none class(psb_ls_csc_sparse_mat), intent(in) :: a,b type(psb_ls_csc_sparse_mat), intent(out) :: c @@ -4628,7 +4631,7 @@ subroutine psb_lscscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -4657,9 +4660,9 @@ subroutine psb_lscscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_ls_csc_sparse_mat), intent(in) :: a,b type(psb_ls_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -4682,29 +4685,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -4712,11 +4715,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index a041302fa..2fa87adf6 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csmv - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -73,7 +73,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -83,7 +83,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_s_csr_csmm - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -418,7 +418,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -426,7 +426,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -434,16 +434,16 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_s_csr_cssv - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -766,7 +766,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -776,26 +776,26 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x) psb_s_csr_cssm - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1030,7 +1030,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1041,9 +1041,9 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1063,14 +1063,14 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == szero) then + if (beta == szero) then call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -1078,7 +1078,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) end if call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) end do @@ -1099,11 +1099,11 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,& - & irp,ja,val,x,ldx,y,ldy,info) - implicit none + & irp,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit integer(psb_ipk_), intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) real(psb_spk_), intent(in) :: val(*), x(ldx,*) @@ -1120,38 +1120,38 @@ contains end if - if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then do i=1, nr - acc = szero + acc = szero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr - acc = szero + acc = szero do j=irp(i), irp(i+1)-2 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then - do i=nr, 1, -1 - acc = szero + if (unit) then + do i=nr, 1, -1 + acc = szero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then - do i=nr, 1, -1 - acc = szero + else if (.not.unit) then + do i=nr, 1, -1 + acc = szero do j=irp(i)+1, irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -1161,96 +1161,96 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/val(irp(i)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/(val(irp(i+1)-1)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/(val(irp(i))) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc end do end do end if @@ -1264,7 +1264,7 @@ end subroutine psb_s_csr_cssm function psb_s_csr_maxval(a) result(res) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_maxval - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1277,7 +1277,7 @@ function psb_s_csr_maxval(a) result(res) res = szero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1286,7 +1286,7 @@ end function psb_s_csr_maxval function psb_s_csr_csnmi(a) result(res) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csnmi - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -1303,7 +1303,7 @@ function psb_s_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -1311,7 +1311,7 @@ function psb_s_csr_csnmi(a) result(res) end function psb_s_csr_csnmi -subroutine psb_s_csr_rowsum(d,a) +subroutine psb_s_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_rowsum @@ -1331,7 +1331,7 @@ subroutine psb_s_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1340,12 +1340,12 @@ subroutine psb_s_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + sone end do @@ -1353,7 +1353,7 @@ subroutine psb_s_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1361,7 +1361,7 @@ subroutine psb_s_csr_rowsum(d,a) end subroutine psb_s_csr_rowsum -subroutine psb_s_csr_arwsum(d,a) +subroutine psb_s_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_arwsum @@ -1381,7 +1381,7 @@ subroutine psb_s_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1391,19 +1391,19 @@ subroutine psb_s_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1411,7 +1411,7 @@ subroutine psb_s_csr_arwsum(d,a) end subroutine psb_s_csr_arwsum -subroutine psb_s_csr_colsum(d,a) +subroutine psb_s_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_colsum @@ -1432,7 +1432,7 @@ subroutine psb_s_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1447,8 +1447,8 @@ subroutine psb_s_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + sone end do @@ -1456,7 +1456,7 @@ subroutine psb_s_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1464,7 +1464,7 @@ subroutine psb_s_csr_colsum(d,a) end subroutine psb_s_csr_colsum -subroutine psb_s_csr_aclsum(d,a) +subroutine psb_s_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_aclsum @@ -1485,7 +1485,7 @@ subroutine psb_s_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1500,8 +1500,8 @@ subroutine psb_s_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + sone end do @@ -1509,7 +1509,7 @@ subroutine psb_s_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1517,11 +1517,11 @@ subroutine psb_s_csr_aclsum(d,a) end subroutine psb_s_csr_aclsum -subroutine psb_s_csr_get_diag(a,d,info) +subroutine psb_s_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_get_diag - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1536,28 +1536,28 @@ subroutine psb_s_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = sone else do i=1, mnm d(i) = szero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = szero end do @@ -1570,12 +1570,12 @@ subroutine psb_s_csr_get_diag(a,d,info) end subroutine psb_s_csr_get_diag -subroutine psb_s_csr_scal(d,a,info,side) +subroutine psb_s_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scal use psb_string_mod - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1585,47 +1585,47 @@ subroutine psb_s_csr_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -1643,11 +1643,11 @@ subroutine psb_s_csr_scal(d,a,info,side) end subroutine psb_s_csr_scal -subroutine psb_s_csr_scals(d,a,info) +subroutine psb_s_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_scals - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1660,7 +1660,7 @@ subroutine psb_s_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1680,7 +1680,7 @@ end subroutine psb_s_csr_scals -! == =================================== +! == =================================== ! ! ! @@ -1690,14 +1690,14 @@ end subroutine psb_s_csr_scals ! ! ! -! == =================================== +! == =================================== -subroutine psb_s_csr_reallocate_nz(nz,a) +subroutine psb_s_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1709,7 +1709,7 @@ subroutine psb_s_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -1723,10 +1723,10 @@ subroutine psb_s_csr_reallocate_nz(nz,a) end subroutine psb_s_csr_reallocate_nz -subroutine psb_s_csr_mold(a,b,info) +subroutine psb_s_csr_mold(a,b,info) use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mold use psb_error_mod - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1735,16 +1735,16 @@ subroutine psb_s_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_s_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -1755,11 +1755,11 @@ subroutine psb_s_csr_mold(a,b,info) end subroutine psb_s_csr_mold -subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1770,26 +1770,26 @@ subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -1797,7 +1797,7 @@ subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1820,7 +1820,7 @@ end subroutine psb_s_csr_allocate_mnnz subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1838,7 +1838,7 @@ subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -1866,35 +1866,35 @@ subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1940,32 +1940,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -1976,7 +1976,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -1987,13 +1987,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_s_csr_csgetptn subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2021,7 +2021,7 @@ subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -2040,27 +2040,27 @@ subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2068,13 +2068,13 @@ subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2121,12 +2121,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -2134,23 +2134,23 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - + if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2162,7 +2162,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2183,7 +2183,7 @@ end subroutine psb_s_csr_csgetrow ! subroutine psb_s_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_tril @@ -2195,7 +2195,7 @@ subroutine psb_s_csr_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_s_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2206,57 +2206,57 @@ subroutine psb_s_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -2265,7 +2265,7 @@ subroutine psb_s_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -2281,7 +2281,7 @@ subroutine psb_s_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -2289,17 +2289,17 @@ subroutine psb_s_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -2318,8 +2318,8 @@ subroutine psb_s_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -2337,7 +2337,7 @@ end subroutine psb_s_csr_tril subroutine psb_s_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_triu @@ -2349,7 +2349,7 @@ subroutine psb_s_csr_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_s_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2360,57 +2360,57 @@ subroutine psb_s_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -2419,7 +2419,7 @@ subroutine psb_s_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -2471,8 +2471,8 @@ subroutine psb_s_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -2489,11 +2489,11 @@ subroutine psb_s_csr_triu(a,u,info,& end subroutine psb_s_csr_triu -subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput_a - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -2511,23 +2511,23 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_; i=1 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_; i=2 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_; i=3 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_; i=4 call psb_errpush(info,name,i_err=(/i/)) goto 9999 @@ -2538,25 +2538,25 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_s_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2582,7 +2582,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2600,13 +2600,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2616,20 +2616,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2641,17 +2641,17 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2676,9 +2676,9 @@ end subroutine psb_s_csr_csput_a subroutine psb_s_csr_reinit(a,clear) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_reinit - implicit none + implicit none - class(psb_s_csr_sparse_mat), intent(inout) :: a + class(psb_s_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2691,16 +2691,16 @@ subroutine psb_s_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = szero call a%set_upd() call a%set_host() @@ -2723,9 +2723,9 @@ subroutine psb_s_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_trim - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz, m + integer(psb_ipk_) :: err_act, info, nz, m character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2738,7 +2738,7 @@ subroutine psb_s_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2752,10 +2752,10 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -2763,13 +2763,13 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='s_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2779,35 +2779,35 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) nz = a%get_nzeros() frmt = psb_s_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -2817,12 +2817,12 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_s_csr_print -subroutine psb_s_cp_csr_from_coo(a,b,info) +subroutine psb_s_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_coo - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b @@ -2840,18 +2840,18 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_s_base_sparse_mat = tmp%psb_s_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -2860,22 +2860,22 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -2891,17 +2891,17 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_s_cp_csr_from_coo -subroutine psb_s_cp_csr_to_coo(a,b,info) +subroutine psb_s_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_to_coo - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b @@ -2940,12 +2940,12 @@ subroutine psb_s_cp_csr_to_coo(a,b,info) end subroutine psb_s_cp_csr_to_coo -subroutine psb_s_mv_csr_to_coo(a,b,info) +subroutine psb_s_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_to_coo - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b @@ -2986,13 +2986,13 @@ end subroutine psb_s_mv_csr_to_coo -subroutine psb_s_mv_csr_from_coo(a,b,info) +subroutine psb_s_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_coo - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b @@ -3018,7 +3018,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -3042,15 +3042,15 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_s_mv_csr_from_coo -subroutine psb_s_mv_csr_to_fmt(a,b,info) +subroutine psb_s_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_to_fmt - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b @@ -3067,9 +3067,9 @@ subroutine psb_s_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_s_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat @@ -3087,12 +3087,12 @@ subroutine psb_s_mv_csr_to_fmt(a,b,info) end subroutine psb_s_mv_csr_to_fmt -subroutine psb_s_cp_csr_to_fmt(a,b,info) +subroutine psb_s_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_to_fmt - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b @@ -3110,10 +3110,10 @@ subroutine psb_s_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_s_csr_sparse_mat) + type is (psb_s_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat nr = a%get_nrows() @@ -3131,11 +3131,11 @@ subroutine psb_s_cp_csr_to_fmt(a,b,info) end subroutine psb_s_cp_csr_to_fmt -subroutine psb_s_mv_csr_from_fmt(a,b,info) +subroutine psb_s_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_mv_csr_from_fmt - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b @@ -3152,10 +3152,10 @@ subroutine psb_s_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_s_csr_sparse_mat) + type is (psb_s_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat @@ -3174,12 +3174,12 @@ end subroutine psb_s_mv_csr_from_fmt -subroutine psb_s_cp_csr_from_fmt(a,b,info) +subroutine psb_s_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_fmt - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b @@ -3196,10 +3196,10 @@ subroutine psb_s_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_s_coo_sparse_mat) + type is (psb_s_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_s_csr_sparse_mat) + type is (psb_s_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat nr = b%get_nrows() @@ -3218,19 +3218,19 @@ end subroutine psb_s_cp_csr_from_fmt subroutine psb_s_csr_clean_zeros(a, info) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_clean_zeros - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nr - integer(psb_ipk_), allocatable :: ilrp(:) - + integer(psb_ipk_), allocatable :: ilrp(:) + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= szero) then @@ -3249,7 +3249,7 @@ subroutine psb_scsrspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_scsrspspmm - implicit none + implicit none class(psb_s_csr_sparse_mat), intent(in) :: a,b type(psb_s_csr_sparse_mat), intent(out) :: c @@ -3260,7 +3260,7 @@ subroutine psb_scsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -3270,7 +3270,7 @@ subroutine psb_scsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -3296,9 +3296,9 @@ subroutine psb_scsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_s_csr_sparse_mat), intent(in) :: a,b type(psb_s_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -3321,49 +3321,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_scsrspspmm @@ -3372,13 +3372,13 @@ end subroutine psb_scsrspspmm ! ! ! ls version -! ! -subroutine psb_ls_csr_get_diag(a,d,info) +! +subroutine psb_ls_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_get_diag - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3393,28 +3393,28 @@ subroutine psb_ls_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = sone else do i=1, mnm d(i) = szero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = szero end do @@ -3427,12 +3427,12 @@ subroutine psb_ls_csr_get_diag(a,d,info) end subroutine psb_ls_csr_get_diag -subroutine psb_ls_csr_scal(d,a,info,side) +subroutine psb_ls_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_scal use psb_string_mod - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3442,47 +3442,47 @@ subroutine psb_ls_csr_scal(d,a,info,side) integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -3500,11 +3500,11 @@ subroutine psb_ls_csr_scal(d,a,info,side) end subroutine psb_ls_csr_scal -subroutine psb_ls_csr_scals(d,a,info) +subroutine psb_ls_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_scals - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3518,7 +3518,7 @@ subroutine psb_ls_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3539,7 +3539,7 @@ end subroutine psb_ls_csr_scals function psb_ls_csr_maxval(a) result(res) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_maxval - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3552,7 +3552,7 @@ function psb_ls_csr_maxval(a) result(res) res = szero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3561,7 +3561,7 @@ end function psb_ls_csr_maxval function psb_ls_csr_csnmi(a) result(res) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csnmi - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res @@ -3578,7 +3578,7 @@ function psb_ls_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -3586,7 +3586,7 @@ function psb_ls_csr_csnmi(a) result(res) end function psb_ls_csr_csnmi -subroutine psb_ls_csr_rowsum(d,a) +subroutine psb_ls_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_rowsum @@ -3606,7 +3606,7 @@ subroutine psb_ls_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3615,12 +3615,12 @@ subroutine psb_ls_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + sone end do @@ -3628,7 +3628,7 @@ subroutine psb_ls_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3636,7 +3636,7 @@ subroutine psb_ls_csr_rowsum(d,a) end subroutine psb_ls_csr_rowsum -subroutine psb_ls_csr_arwsum(d,a) +subroutine psb_ls_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_arwsum @@ -3656,7 +3656,7 @@ subroutine psb_ls_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3666,19 +3666,19 @@ subroutine psb_ls_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = szero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + sone end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3686,7 +3686,7 @@ subroutine psb_ls_csr_arwsum(d,a) end subroutine psb_ls_csr_arwsum -subroutine psb_ls_csr_colsum(d,a) +subroutine psb_ls_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_colsum @@ -3707,7 +3707,7 @@ subroutine psb_ls_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3722,8 +3722,8 @@ subroutine psb_ls_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + sone end do @@ -3731,7 +3731,7 @@ subroutine psb_ls_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3739,7 +3739,7 @@ subroutine psb_ls_csr_colsum(d,a) end subroutine psb_ls_csr_colsum -subroutine psb_ls_csr_aclsum(d,a) +subroutine psb_ls_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_aclsum @@ -3760,7 +3760,7 @@ subroutine psb_ls_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3775,8 +3775,8 @@ subroutine psb_ls_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + sone end do @@ -3784,7 +3784,7 @@ subroutine psb_ls_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3793,7 +3793,7 @@ subroutine psb_ls_csr_aclsum(d,a) end subroutine psb_ls_csr_aclsum -! == =================================== +! == =================================== ! ! ! @@ -3803,14 +3803,14 @@ end subroutine psb_ls_csr_aclsum ! ! ! -! == =================================== +! == =================================== -subroutine psb_ls_csr_reallocate_nz(nz,a) +subroutine psb_ls_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_reallocate_nz - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_ls_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3822,7 +3822,7 @@ subroutine psb_ls_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -3836,10 +3836,10 @@ subroutine psb_ls_csr_reallocate_nz(nz,a) end subroutine psb_ls_csr_reallocate_nz -subroutine psb_ls_csr_mold(a,b,info) +subroutine psb_ls_csr_mold(a,b,info) use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_mold use psb_error_mod - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3848,16 +3848,16 @@ subroutine psb_ls_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_ls_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -3868,11 +3868,11 @@ subroutine psb_ls_csr_mold(a,b,info) end subroutine psb_ls_csr_mold -subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_ls_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -3884,26 +3884,26 @@ subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -3911,7 +3911,7 @@ subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -3934,7 +3934,7 @@ end subroutine psb_ls_csr_allocate_mnnz subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3952,7 +3952,7 @@ subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -3981,35 +3981,35 @@ subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4055,32 +4055,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -4091,7 +4091,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -4102,13 +4102,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_ls_csr_csgetptn subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4127,7 +4127,7 @@ subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -4137,7 +4137,7 @@ subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -4156,22 +4156,22 @@ subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -4179,13 +4179,13 @@ subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4232,12 +4232,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -4245,21 +4245,21 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4271,7 +4271,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4292,7 +4292,7 @@ end subroutine psb_ls_csr_csgetrow ! subroutine psb_ls_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_tril @@ -4304,7 +4304,7 @@ subroutine psb_ls_csr_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ls_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4316,57 +4316,57 @@ subroutine psb_ls_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -4375,7 +4375,7 @@ subroutine psb_ls_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -4391,7 +4391,7 @@ subroutine psb_ls_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -4399,17 +4399,17 @@ subroutine psb_ls_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -4428,8 +4428,8 @@ subroutine psb_ls_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -4447,7 +4447,7 @@ end subroutine psb_ls_csr_tril subroutine psb_ls_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_triu @@ -4459,7 +4459,7 @@ subroutine psb_ls_csr_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_ls_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4471,57 +4471,57 @@ subroutine psb_ls_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -4530,7 +4530,7 @@ subroutine psb_ls_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -4582,8 +4582,8 @@ subroutine psb_ls_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -4600,11 +4600,11 @@ subroutine psb_ls_csr_triu(a,u,info,& end subroutine psb_ls_csr_triu -subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csput_a - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) @@ -4624,24 +4624,24 @@ subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then - info = psb_err_iarg_neg_; + if (nz <= 0) then + info = psb_err_iarg_neg_; call psb_errpush(info,name,m_err=(/1/)) goto 9999 end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/2/)) goto 9999 end if - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/3/)) goto 9999 end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/4/)) goto 9999 end if @@ -4651,25 +4651,25 @@ subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_ls_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -4695,7 +4695,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -4713,13 +4713,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -4729,20 +4729,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 inc = nc - ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -4754,18 +4754,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 inc = nc ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -4790,9 +4790,9 @@ end subroutine psb_ls_csr_csput_a subroutine psb_ls_csr_reinit(a,clear) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_reinit - implicit none + implicit none - class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4805,16 +4805,16 @@ subroutine psb_ls_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = szero call a%set_upd() call a%set_host() @@ -4837,7 +4837,7 @@ subroutine psb_ls_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_trim - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, m integer(psb_ipk_) :: err_act, info @@ -4853,7 +4853,7 @@ subroutine psb_ls_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4866,10 +4866,10 @@ end subroutine psb_ls_csr_trim subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4877,13 +4877,13 @@ subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='ls_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4892,36 +4892,36 @@ subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_ls_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -4931,12 +4931,12 @@ subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_ls_csr_print -subroutine psb_ls_cp_csr_from_coo(a,b,info) +subroutine psb_ls_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_from_coo - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(in) :: b @@ -4954,18 +4954,18 @@ subroutine psb_ls_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_ls_base_sparse_mat = tmp%psb_ls_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -4974,22 +4974,22 @@ subroutine psb_ls_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -5005,17 +5005,17 @@ subroutine psb_ls_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_ls_cp_csr_from_coo -subroutine psb_ls_cp_csr_to_coo(a,b,info) +subroutine psb_ls_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_to_coo - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -5054,12 +5054,12 @@ subroutine psb_ls_cp_csr_to_coo(a,b,info) end subroutine psb_ls_cp_csr_to_coo -subroutine psb_ls_mv_csr_to_coo(a,b,info) +subroutine psb_ls_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_to_coo - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -5100,13 +5100,13 @@ end subroutine psb_ls_mv_csr_to_coo -subroutine psb_ls_mv_csr_from_coo(a,b,info) +subroutine psb_ls_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_from_coo - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_coo_sparse_mat), intent(inout) :: b @@ -5132,7 +5132,7 @@ subroutine psb_ls_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -5156,15 +5156,15 @@ subroutine psb_ls_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_ls_mv_csr_from_coo -subroutine psb_ls_mv_csr_to_fmt(a,b,info) +subroutine psb_ls_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_to_fmt - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b @@ -5181,9 +5181,9 @@ subroutine psb_ls_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_ls_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat @@ -5201,12 +5201,12 @@ subroutine psb_ls_mv_csr_to_fmt(a,b,info) end subroutine psb_ls_mv_csr_to_fmt -subroutine psb_ls_cp_csr_to_fmt(a,b,info) +subroutine psb_ls_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_to_fmt - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b @@ -5224,10 +5224,10 @@ subroutine psb_ls_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_ls_csr_sparse_mat) + type is (psb_ls_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat nr = a%get_nrows() @@ -5245,11 +5245,11 @@ subroutine psb_ls_cp_csr_to_fmt(a,b,info) end subroutine psb_ls_cp_csr_to_fmt -subroutine psb_ls_mv_csr_from_fmt(a,b,info) +subroutine psb_ls_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_from_fmt - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b @@ -5266,10 +5266,10 @@ subroutine psb_ls_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_ls_csr_sparse_mat) + type is (psb_ls_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat @@ -5288,12 +5288,12 @@ end subroutine psb_ls_mv_csr_from_fmt -subroutine psb_ls_cp_csr_from_fmt(a,b,info) +subroutine psb_ls_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_s_base_mat_mod use psb_realloc_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_from_fmt - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(in) :: b @@ -5310,10 +5310,10 @@ subroutine psb_ls_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_ls_coo_sparse_mat) + type is (psb_ls_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_ls_csr_sparse_mat) + type is (psb_ls_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat nr = b%get_nrows() @@ -5333,19 +5333,19 @@ end subroutine psb_ls_cp_csr_from_fmt subroutine psb_ls_csr_clean_zeros(a, info) use psb_error_mod use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_clean_zeros - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nr - integer(psb_lpk_), allocatable :: ilrp(:) - - info = 0 + integer(psb_lpk_), allocatable :: ilrp(:) + + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= szero) then @@ -5364,7 +5364,7 @@ subroutine psb_lscsrspspmm(a,b,c,info) use psb_s_mat_mod use psb_serial_mod, psb_protect_name => psb_lscsrspspmm - implicit none + implicit none class(psb_ls_csr_sparse_mat), intent(in) :: a,b type(psb_ls_csr_sparse_mat), intent(out) :: c @@ -5375,7 +5375,7 @@ subroutine psb_lscsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -5385,7 +5385,7 @@ subroutine psb_lscsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -5410,9 +5410,9 @@ subroutine psb_lscsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_ls_csr_sparse_mat), intent(in) :: a,b type(psb_ls_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -5435,50 +5435,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_lscsrspspmm - diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index c0c7007d6..867f9fa4c 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! s_mat_impl: ! implementation of the outer matrix methods. @@ -43,7 +43,7 @@ ! ! ! -! Setters +! Setters ! ! ! @@ -53,10 +53,10 @@ ! == =================================== -subroutine psb_s_set_nrows(m,a) +subroutine psb_s_set_nrows(m,a) use psb_s_mat_mod, psb_protect_name => psb_s_set_nrows use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -64,7 +64,7 @@ subroutine psb_s_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -82,10 +82,10 @@ subroutine psb_s_set_nrows(m,a) end subroutine psb_s_set_nrows -subroutine psb_s_set_ncols(n,a) +subroutine psb_s_set_ncols(n,a) use psb_s_mat_mod, psb_protect_name => psb_s_set_ncols use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -93,7 +93,7 @@ subroutine psb_s_set_ncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -112,16 +112,16 @@ end subroutine psb_s_set_ncols ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_s_set_dupl(n,a) +subroutine psb_s_set_dupl(n,a) use psb_s_mat_mod, psb_protect_name => psb_s_set_dupl use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -129,7 +129,7 @@ subroutine psb_s_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -151,17 +151,17 @@ end subroutine psb_s_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_s_set_null(a) +subroutine psb_s_set_null(a) use psb_s_mat_mod, psb_protect_name => psb_s_set_null use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -179,17 +179,17 @@ subroutine psb_s_set_null(a) end subroutine psb_s_set_null -subroutine psb_s_set_bld(a) +subroutine psb_s_set_bld(a) use psb_s_mat_mod, psb_protect_name => psb_s_set_bld use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -208,17 +208,17 @@ subroutine psb_s_set_bld(a) end subroutine psb_s_set_bld -subroutine psb_s_set_upd(a) +subroutine psb_s_set_upd(a) use psb_s_mat_mod, psb_protect_name => psb_s_set_upd use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -238,17 +238,17 @@ subroutine psb_s_set_upd(a) end subroutine psb_s_set_upd -subroutine psb_s_set_asb(a) +subroutine psb_s_set_asb(a) use psb_s_mat_mod, psb_protect_name => psb_s_set_asb use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -267,10 +267,10 @@ subroutine psb_s_set_asb(a) end subroutine psb_s_set_asb -subroutine psb_s_set_sorted(a,val) +subroutine psb_s_set_sorted(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_sorted use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -278,7 +278,7 @@ subroutine psb_s_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -297,10 +297,10 @@ subroutine psb_s_set_sorted(a,val) end subroutine psb_s_set_sorted -subroutine psb_s_set_triangle(a,val) +subroutine psb_s_set_triangle(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_triangle use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -308,7 +308,7 @@ subroutine psb_s_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -326,10 +326,10 @@ subroutine psb_s_set_triangle(a,val) end subroutine psb_s_set_triangle -subroutine psb_s_set_symmetric(a,val) +subroutine psb_s_set_symmetric(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -337,7 +337,7 @@ subroutine psb_s_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -355,10 +355,10 @@ subroutine psb_s_set_symmetric(a,val) end subroutine psb_s_set_symmetric -subroutine psb_s_set_unit(a,val) +subroutine psb_s_set_unit(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_unit use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -366,7 +366,7 @@ subroutine psb_s_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -385,10 +385,10 @@ subroutine psb_s_set_unit(a,val) end subroutine psb_s_set_unit -subroutine psb_s_set_lower(a,val) +subroutine psb_s_set_lower(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_lower use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -396,7 +396,7 @@ subroutine psb_s_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -415,10 +415,10 @@ subroutine psb_s_set_lower(a,val) end subroutine psb_s_set_lower -subroutine psb_s_set_upper(a,val) +subroutine psb_s_set_upper(a,val) use psb_s_mat_mod, psb_protect_name => psb_s_set_upper use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -426,7 +426,7 @@ subroutine psb_s_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -456,16 +456,16 @@ end subroutine psb_s_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) use psb_s_mat_mod, psb_protect_name => psb_s_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -476,7 +476,7 @@ subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -496,10 +496,10 @@ end subroutine psb_s_sparse_print subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_s_mat_mod, psb_protect_name => psb_s_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_sspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_sspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -511,24 +511,24 @@ subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -547,13 +547,13 @@ end subroutine psb_s_n_sparse_print subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) use psb_s_mat_mod, psb_protect_name => psb_s_get_neigh use psb_error_mod - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -561,7 +561,7 @@ subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -582,17 +582,17 @@ end subroutine psb_s_get_neigh -subroutine psb_s_csall(nr,nc,a,info,nz) +subroutine psb_s_csall(nr,nc,a,info,nz) use psb_s_mat_mod, psb_protect_name => psb_s_csall use psb_s_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -602,13 +602,13 @@ subroutine psb_s_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_s_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -619,10 +619,10 @@ subroutine psb_s_csall(nr,nc,a,info,nz) end subroutine psb_s_csall -subroutine psb_s_reallocate_nz(nz,a) +subroutine psb_s_reallocate_nz(nz,a) use psb_s_mat_mod, psb_protect_name => psb_s_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -630,7 +630,7 @@ subroutine psb_s_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -647,31 +647,31 @@ subroutine psb_s_reallocate_nz(nz,a) end subroutine psb_s_reallocate_nz -subroutine psb_s_free(a) +subroutine psb_s_free(a) use psb_s_mat_mod, psb_protect_name => psb_s_free use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_s_free -subroutine psb_s_trim(a) +subroutine psb_s_trim(a) use psb_s_mat_mod, psb_protect_name => psb_s_trim use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -689,11 +689,11 @@ end subroutine psb_s_trim -subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_mat_mod, psb_protect_name => psb_s_csput_a use psb_s_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -705,15 +705,15 @@ subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -725,13 +725,13 @@ subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_s_csput_a -subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_mat_mod, psb_protect_name => psb_s_csput_v use psb_s_base_mat_mod use psb_s_vect_mod, only : psb_s_vect_type use psb_i_vect_mod, only : psb_i_vect_type use psb_error_mod - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a type(psb_s_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -744,19 +744,19 @@ subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -771,7 +771,7 @@ end subroutine psb_s_csput_v subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -794,7 +794,7 @@ subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -803,7 +803,7 @@ subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -818,7 +818,7 @@ end subroutine psb_s_csgetptn subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -842,7 +842,7 @@ subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -851,7 +851,7 @@ subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -868,7 +868,7 @@ end subroutine psb_s_csgetrow subroutine psb_s_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -893,31 +893,31 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -936,7 +936,7 @@ subroutine psb_s_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_s_base_mat_mod use psb_s_mat_mod, psb_protect_name => psb_s_tril - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -951,22 +951,22 @@ subroutine psb_s_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -975,7 +975,7 @@ subroutine psb_s_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -993,7 +993,7 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_s_base_mat_mod use psb_s_mat_mod, psb_protect_name => psb_s_triu - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -1009,24 +1009,24 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -1035,7 +1035,7 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1047,9 +1047,10 @@ subroutine psb_s_triu(a,u,info,diag,imin,imax,& end subroutine psb_s_triu + subroutine psb_s_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -1069,24 +1070,24 @@ subroutine psb_s_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1099,7 +1100,7 @@ end subroutine psb_s_csclip subroutine psb_s_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -1118,14 +1119,14 @@ subroutine psb_s_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -1133,8 +1134,8 @@ subroutine psb_s_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1147,7 +1148,7 @@ end subroutine psb_s_csclip_ip subroutine psb_s_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -1166,7 +1167,7 @@ subroutine psb_s_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1174,7 +1175,7 @@ subroutine psb_s_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1190,7 +1191,7 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_cscnv - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1207,7 +1208,7 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1219,38 +1220,38 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_s_csr_sparse_mat :: altmp, stat=info) + allocate(psb_s_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_s_coo_sparse_mat :: altmp, stat=info) + allocate(psb_s_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_s_csc_sparse_mat :: altmp, stat=info) + allocate(psb_s_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -1268,7 +1269,7 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%set_asb() + call b%set_asb() call psb_erractionrestore(err_act) return @@ -1283,7 +1284,7 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_ip - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -1300,15 +1301,15 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -1318,29 +1319,29 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_s_csr_sparse_mat :: altmp, stat=info) + allocate(psb_s_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_s_coo_sparse_mat :: altmp, stat=info) + allocate(psb_s_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_s_csc_sparse_mat :: altmp, stat=info) + allocate(psb_s_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1359,7 +1360,7 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) call move_alloc(altmp,a%a) call a%trim() - call a%set_asb() + call a%set_asb() call psb_erractionrestore(err_act) return @@ -1376,7 +1377,7 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_base - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -1391,19 +1392,19 @@ subroutine psb_s_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -1425,7 +1426,7 @@ end subroutine psb_s_cscnv_base subroutine psb_s_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -1444,15 +1445,15 @@ subroutine psb_s_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1461,8 +1462,8 @@ subroutine psb_s_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1485,7 +1486,7 @@ end subroutine psb_s_clip_d subroutine psb_s_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -1503,13 +1504,13 @@ subroutine psb_s_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -1520,8 +1521,8 @@ subroutine psb_s_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1546,7 +1547,7 @@ subroutine psb_s_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_mv_from - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1564,7 +1565,7 @@ subroutine psb_s_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_from - implicit none + implicit none class(psb_sspmat_type), intent(out) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -1573,7 +1574,7 @@ subroutine psb_s_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -1582,8 +1583,8 @@ subroutine psb_s_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1599,11 +1600,11 @@ subroutine psb_s_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_mv_to - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -1614,7 +1615,7 @@ subroutine psb_s_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_to - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1631,14 +1632,14 @@ subroutine psb_s_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_s_mold subroutine psb_sspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_sspmat_type_move - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1659,7 +1660,7 @@ subroutine psb_sspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_sspmat_clone - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1671,10 +1672,10 @@ subroutine psb_sspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1691,7 +1692,7 @@ subroutine psb_s_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_transp_1mat - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1700,7 +1701,7 @@ subroutine psb_s_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1724,7 +1725,7 @@ subroutine psb_s_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_transp_2mat - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b @@ -1734,18 +1735,18 @@ subroutine psb_s_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -1762,7 +1763,7 @@ subroutine psb_s_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_transc_1mat - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1771,7 +1772,7 @@ subroutine psb_s_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1795,7 +1796,7 @@ subroutine psb_s_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_s_transc_2mat - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b @@ -1805,18 +1806,18 @@ subroutine psb_s_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -1832,9 +1833,9 @@ end subroutine psb_s_transc_2mat subroutine psb_s_asb(a,mold) use psb_s_mat_mod, psb_protect_name => psb_s_asb use psb_error_mod - implicit none + implicit none - class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), optional, intent(in) :: mold class(psb_s_base_sparse_mat), allocatable :: tmp class(psb_s_base_sparse_mat), pointer :: mld @@ -1842,15 +1843,15 @@ subroutine psb_s_asb(a,mold) character(len=20) :: name='s_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -1861,7 +1862,7 @@ subroutine psb_s_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -1876,21 +1877,21 @@ end subroutine psb_s_asb subroutine psb_s_reinit(a,clear) use psb_s_mat_mod, psb_protect_name => psb_s_reinit use psb_error_mod - implicit none + implicit none - class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -1925,10 +1926,10 @@ end subroutine psb_s_reinit ! == =================================== -subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_s_mat_mod, psb_protect_name => psb_s_csmm - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1940,14 +1941,14 @@ subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1958,10 +1959,10 @@ subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_s_csmm -subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_s_mat_mod, psb_protect_name => psb_s_csmv - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1973,14 +1974,14 @@ subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1990,11 +1991,11 @@ subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_s_csmv -subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) +subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_s_vect_mod use psb_s_mat_mod, psb_protect_name => psb_s_csmv_vect - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta type(psb_s_vect_type), intent(inout) :: x @@ -2007,25 +2008,25 @@ subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x%v,beta,y%v,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2037,10 +2038,10 @@ end subroutine psb_s_csmv_vect -subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_s_mat_mod, psb_protect_name => psb_s_cssm - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -2053,14 +2054,14 @@ subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2072,10 +2073,10 @@ subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_s_cssm -subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_s_mat_mod, psb_protect_name => psb_s_cssv - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -2088,15 +2089,15 @@ subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2108,11 +2109,11 @@ subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_s_cssv -subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_s_vect_mod use psb_s_mat_mod, psb_protect_name => psb_s_cssv_vect - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta type(psb_s_vect_type), intent(inout) :: x @@ -2126,33 +2127,33 @@ subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then + if (present(d)) then + if (.not.allocated(d%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2167,7 +2168,7 @@ function psb_s_maxval(a) result(res) use psb_s_mat_mod, psb_protect_name => psb_s_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -2178,7 +2179,7 @@ function psb_s_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2198,7 +2199,7 @@ function psb_s_csnmi(a) result(res) use psb_s_mat_mod, psb_protect_name => psb_s_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -2208,7 +2209,7 @@ function psb_s_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2229,7 +2230,7 @@ function psb_s_csnm1(a) result(res) use psb_s_mat_mod, psb_protect_name => psb_s_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -2239,7 +2240,7 @@ function psb_s_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2260,7 +2261,7 @@ function psb_s_rowsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_s_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2272,7 @@ function psb_s_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2293,7 +2294,7 @@ function psb_s_arwsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_s_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2304,7 +2305,7 @@ function psb_s_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2327,7 +2328,7 @@ function psb_s_colsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_s_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2338,7 +2339,7 @@ function psb_s_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2361,7 +2362,7 @@ function psb_s_aclsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_s_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2372,7 +2373,7 @@ function psb_s_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2396,7 +2397,7 @@ function psb_s_get_diag(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_s_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2407,14 +2408,14 @@ function psb_s_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -2435,7 +2436,7 @@ subroutine psb_s_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_scal - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2447,7 +2448,7 @@ subroutine psb_s_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2470,7 +2471,7 @@ subroutine psb_s_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_scals - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -2481,7 +2482,7 @@ subroutine psb_s_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2499,12 +2500,152 @@ subroutine psb_s_scals(d,a,info) end subroutine psb_s_scals +subroutine psb_s_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_scalplusidentity + implicit none + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_scalplusidentity + +subroutine psb_s_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_spaxpby + implicit none + real(psb_spk_), intent(in) :: alpha + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: beta + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_spaxpby + +function psb_s_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cmpval + implicit none + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_s_cmpval + +function psb_s_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cmpmat + implicit none + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_s_cmpmat + subroutine psb_s_mv_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_mv_from_lb - implicit none - + implicit none + class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2512,16 +2653,16 @@ subroutine psb_s_mv_from_lb(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) - + end subroutine psb_s_mv_from_lb - + subroutine psb_s_cp_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_from_lb - implicit none - + implicit none + class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2536,30 +2677,30 @@ subroutine psb_s_mv_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_mv_to_lb - implicit none - + implicit none + class(psb_sspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_lfmt(b,info) call a%free() end if - + end subroutine psb_s_mv_to_lb subroutine psb_s_cp_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_to_lb - implicit none + implicit none class(psb_sspmat_type), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -2572,7 +2713,7 @@ subroutine psb_s_mv_from_l(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_mv_from_l - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -2585,21 +2726,21 @@ subroutine psb_s_mv_from_l(a,b) call a%free() end if call b%free() - + end subroutine psb_s_mv_from_l - + subroutine psb_s_cp_from_l(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_from_l - implicit none + implicit none class(psb_sspmat_type), intent(out) :: a class(psb_lsspmat_type), intent(in) :: b integer(psb_ipk_) :: info - info = psb_success_ + info = psb_success_ if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_lfmt(b%a,info) @@ -2612,12 +2753,12 @@ subroutine psb_s_mv_to_l(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_mv_to_l - implicit none + implicit none class(psb_sspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_ls_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_lfmt(b%a,info) @@ -2625,26 +2766,26 @@ subroutine psb_s_mv_to_l(a,b) call b%free() end if call a%free() - + end subroutine psb_s_mv_to_l subroutine psb_s_cp_to_l(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_s_cp_to_l - implicit none - + implicit none + class(psb_sspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_ls_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_lfmt(b%a,info) else call b%free() end if - + end subroutine psb_s_cp_to_l @@ -2654,10 +2795,10 @@ end subroutine psb_s_cp_to_l ! -subroutine psb_ls_set_lnrows(m,a) +subroutine psb_ls_set_lnrows(m,a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_lnrows use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2665,7 +2806,7 @@ subroutine psb_ls_set_lnrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2683,10 +2824,10 @@ subroutine psb_ls_set_lnrows(m,a) end subroutine psb_ls_set_lnrows #if defined(IPK4) && defined(LPK8) -subroutine psb_ls_set_inrows(m,a) +subroutine psb_ls_set_inrows(m,a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_inrows use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2694,7 +2835,7 @@ subroutine psb_ls_set_inrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2712,10 +2853,10 @@ subroutine psb_ls_set_inrows(m,a) end subroutine psb_ls_set_inrows #endif -subroutine psb_ls_set_lncols(n,a) +subroutine psb_ls_set_lncols(n,a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_lncols use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2723,7 +2864,7 @@ subroutine psb_ls_set_lncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2740,10 +2881,10 @@ subroutine psb_ls_set_lncols(n,a) end subroutine psb_ls_set_lncols #if defined(IPK4) && defined(LPK8) -subroutine psb_ls_set_incols(n,a) +subroutine psb_ls_set_incols(n,a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_incols use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2751,7 +2892,7 @@ subroutine psb_ls_set_incols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2770,16 +2911,16 @@ end subroutine psb_ls_set_incols #endif ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_ls_set_dupl(n,a) +subroutine psb_ls_set_dupl(n,a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_dupl use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2787,7 +2928,7 @@ subroutine psb_ls_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2809,17 +2950,17 @@ end subroutine psb_ls_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_ls_set_null(a) +subroutine psb_ls_set_null(a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_null use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2837,17 +2978,17 @@ subroutine psb_ls_set_null(a) end subroutine psb_ls_set_null -subroutine psb_ls_set_bld(a) +subroutine psb_ls_set_bld(a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_bld use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2866,17 +3007,17 @@ subroutine psb_ls_set_bld(a) end subroutine psb_ls_set_bld -subroutine psb_ls_set_upd(a) +subroutine psb_ls_set_upd(a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_upd use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2896,17 +3037,17 @@ subroutine psb_ls_set_upd(a) end subroutine psb_ls_set_upd -subroutine psb_ls_set_asb(a) +subroutine psb_ls_set_asb(a) use psb_s_mat_mod, psb_protect_name => psb_ls_set_asb use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2925,10 +3066,10 @@ subroutine psb_ls_set_asb(a) end subroutine psb_ls_set_asb -subroutine psb_ls_set_sorted(a,val) +subroutine psb_ls_set_sorted(a,val) use psb_s_mat_mod, psb_protect_name => psb_ls_set_sorted use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2936,7 +3077,7 @@ subroutine psb_ls_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2955,10 +3096,10 @@ subroutine psb_ls_set_sorted(a,val) end subroutine psb_ls_set_sorted -subroutine psb_ls_set_triangle(a,val) +subroutine psb_ls_set_triangle(a,val) use psb_s_mat_mod, psb_protect_name => psb_ls_set_triangle use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2966,7 +3107,7 @@ subroutine psb_ls_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2984,10 +3125,10 @@ subroutine psb_ls_set_triangle(a,val) end subroutine psb_ls_set_triangle -subroutine psb_ls_set_symmetric(a,val) +subroutine psb_ls_set_symmetric(a,val) use psb_s_mat_mod, psb_protect_name => psb_ls_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2995,7 +3136,7 @@ subroutine psb_ls_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3013,10 +3154,10 @@ subroutine psb_ls_set_symmetric(a,val) end subroutine psb_ls_set_symmetric -subroutine psb_ls_set_unit(a,val) +subroutine psb_ls_set_unit(a,val) use psb_s_mat_mod, psb_protect_name => psb_ls_set_unit use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3024,7 +3165,7 @@ subroutine psb_ls_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3043,10 +3184,10 @@ subroutine psb_ls_set_unit(a,val) end subroutine psb_ls_set_unit -subroutine psb_ls_set_lower(a,val) +subroutine psb_ls_set_lower(a,val) use psb_s_mat_mod, psb_protect_name => psb_ls_set_lower use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3054,7 +3195,7 @@ subroutine psb_ls_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3073,10 +3214,10 @@ subroutine psb_ls_set_lower(a,val) end subroutine psb_ls_set_lower -subroutine psb_ls_set_upper(a,val) +subroutine psb_ls_set_upper(a,val) use psb_s_mat_mod, psb_protect_name => psb_ls_set_upper use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3084,7 +3225,7 @@ subroutine psb_ls_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3114,16 +3255,16 @@ end subroutine psb_ls_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) use psb_s_mat_mod, psb_protect_name => psb_ls_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3134,7 +3275,7 @@ subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3154,10 +3295,10 @@ end subroutine psb_ls_sparse_print subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_s_mat_mod, psb_protect_name => psb_ls_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_lsspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_lsspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3169,24 +3310,24 @@ subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -3205,13 +3346,13 @@ end subroutine psb_ls_n_sparse_print subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) use psb_s_mat_mod, psb_protect_name => psb_ls_get_neigh use psb_error_mod - implicit none - class(psb_lsspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -3219,7 +3360,7 @@ subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3240,17 +3381,17 @@ end subroutine psb_ls_get_neigh -subroutine psb_ls_csall(nr,nc,a,info,nz) +subroutine psb_ls_csall(nr,nc,a,info,nz) use psb_s_mat_mod, psb_protect_name => psb_ls_csall use psb_s_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -3260,13 +3401,13 @@ subroutine psb_ls_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -3277,10 +3418,10 @@ subroutine psb_ls_csall(nr,nc,a,info,nz) end subroutine psb_ls_csall -subroutine psb_ls_reallocate_nz(nz,a) +subroutine psb_ls_reallocate_nz(nz,a) use psb_s_mat_mod, psb_protect_name => psb_ls_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3288,7 +3429,7 @@ subroutine psb_ls_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3305,31 +3446,31 @@ subroutine psb_ls_reallocate_nz(nz,a) end subroutine psb_ls_reallocate_nz -subroutine psb_ls_free(a) +subroutine psb_ls_free(a) use psb_s_mat_mod, psb_protect_name => psb_ls_free use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_ls_free -subroutine psb_ls_trim(a) +subroutine psb_ls_trim(a) use psb_s_mat_mod, psb_protect_name => psb_ls_trim use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3347,11 +3488,11 @@ end subroutine psb_ls_trim -subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_mat_mod, psb_protect_name => psb_ls_csput_a use psb_s_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -3363,15 +3504,15 @@ subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3383,13 +3524,13 @@ subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_ls_csput_a -subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_s_mat_mod, psb_protect_name => psb_ls_csput_v use psb_s_base_mat_mod use psb_s_vect_mod, only : psb_s_vect_type use psb_l_vect_mod, only : psb_l_vect_type use psb_error_mod - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a type(psb_s_vect_type), intent(inout) :: val type(psb_l_vect_type), intent(inout) :: ia, ja @@ -3402,19 +3543,19 @@ subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3429,7 +3570,7 @@ end subroutine psb_ls_csput_v subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -3452,7 +3593,7 @@ subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3461,7 +3602,7 @@ subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3476,7 +3617,7 @@ end subroutine psb_ls_csgetptn subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -3500,7 +3641,7 @@ subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3509,7 +3650,7 @@ subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3526,7 +3667,7 @@ end subroutine psb_ls_csgetrow subroutine psb_ls_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -3551,31 +3692,31 @@ subroutine psb_ls_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3594,7 +3735,7 @@ subroutine psb_ls_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_s_base_mat_mod use psb_s_mat_mod, psb_protect_name => psb_ls_tril - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -3609,22 +3750,22 @@ subroutine psb_ls_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3633,7 +3774,7 @@ subroutine psb_ls_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3651,7 +3792,7 @@ subroutine psb_ls_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_s_base_mat_mod use psb_s_mat_mod, psb_protect_name => psb_ls_triu - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -3667,24 +3808,24 @@ subroutine psb_ls_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3693,7 +3834,7 @@ subroutine psb_ls_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3708,7 +3849,7 @@ end subroutine psb_ls_triu subroutine psb_ls_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -3728,24 +3869,24 @@ subroutine psb_ls_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3758,7 +3899,7 @@ end subroutine psb_ls_csclip subroutine psb_ls_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -3777,14 +3918,14 @@ subroutine psb_ls_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -3792,8 +3933,8 @@ subroutine psb_ls_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3806,7 +3947,7 @@ end subroutine psb_ls_csclip_ip subroutine psb_ls_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -3825,7 +3966,7 @@ subroutine psb_ls_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3833,7 +3974,7 @@ subroutine psb_ls_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3852,7 +3993,7 @@ subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3869,7 +4010,7 @@ subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3881,38 +4022,38 @@ subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) + allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) + allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) + allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -3930,7 +4071,7 @@ subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%asb() + call b%asb() call psb_erractionrestore(err_act) return @@ -3947,7 +4088,7 @@ subroutine psb_ls_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv_ip - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3964,15 +4105,15 @@ subroutine psb_ls_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -3982,29 +4123,29 @@ subroutine psb_ls_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) + allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) + allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) + allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4022,7 +4163,7 @@ subroutine psb_ls_cscnv_ip(a,info,type,mold,dupl) end if call move_alloc(altmp,a%a) - call a%set_asb() + call a%set_asb() call a%trim() call psb_erractionrestore(err_act) return @@ -4040,7 +4181,7 @@ subroutine psb_ls_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv_base - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_ls_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -4055,19 +4196,19 @@ subroutine psb_ls_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -4089,7 +4230,7 @@ end subroutine psb_ls_cscnv_base subroutine psb_ls_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -4108,15 +4249,15 @@ subroutine psb_ls_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4125,8 +4266,8 @@ subroutine psb_ls_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4149,7 +4290,7 @@ end subroutine psb_ls_clip_d subroutine psb_ls_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_s_base_mat_mod @@ -4167,13 +4308,13 @@ subroutine psb_ls_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -4184,8 +4325,8 @@ subroutine psb_ls_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4210,7 +4351,7 @@ subroutine psb_ls_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4228,7 +4369,7 @@ subroutine psb_ls_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from - implicit none + implicit none class(psb_lsspmat_type), intent(out) :: a class(psb_ls_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -4237,7 +4378,7 @@ subroutine psb_ls_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -4246,8 +4387,8 @@ subroutine psb_ls_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4263,11 +4404,11 @@ subroutine psb_ls_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -4278,7 +4419,7 @@ subroutine psb_ls_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_ls_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4295,14 +4436,14 @@ subroutine psb_ls_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_ls_mold subroutine psb_lsspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_lsspmat_type_move - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4323,7 +4464,7 @@ subroutine psb_lsspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_lsspmat_clone - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a class(psb_lsspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4335,10 +4476,10 @@ subroutine psb_lsspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4355,7 +4496,7 @@ subroutine psb_ls_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_transp_1mat - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4364,7 +4505,7 @@ subroutine psb_ls_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4388,7 +4529,7 @@ subroutine psb_ls_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_transp_2mat - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: b @@ -4398,18 +4539,18 @@ subroutine psb_ls_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -4426,7 +4567,7 @@ subroutine psb_ls_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_transc_1mat - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4435,7 +4576,7 @@ subroutine psb_ls_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4459,7 +4600,7 @@ subroutine psb_ls_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_s_mat_mod, psb_protect_name => psb_ls_transc_2mat - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_lsspmat_type), intent(inout) :: b @@ -4469,18 +4610,18 @@ subroutine psb_ls_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -4496,9 +4637,9 @@ end subroutine psb_ls_transc_2mat subroutine psb_ls_asb(a,mold) use psb_s_mat_mod, psb_protect_name => psb_ls_asb use psb_error_mod - implicit none + implicit none - class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: a class(psb_ls_base_sparse_mat), optional, intent(in) :: mold class(psb_ls_base_sparse_mat), allocatable :: tmp class(psb_ls_base_sparse_mat), pointer :: mld @@ -4506,15 +4647,15 @@ subroutine psb_ls_asb(a,mold) character(len=20) :: name='ls_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -4525,7 +4666,7 @@ subroutine psb_ls_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -4540,21 +4681,21 @@ end subroutine psb_ls_asb subroutine psb_ls_reinit(a,clear) use psb_s_mat_mod, psb_protect_name => psb_ls_reinit use psb_error_mod - implicit none + implicit none - class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -4579,7 +4720,7 @@ function psb_ls_get_diag(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_ls_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4590,14 +4731,14 @@ function psb_ls_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -4618,7 +4759,7 @@ subroutine psb_ls_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_scal - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4630,7 +4771,7 @@ subroutine psb_ls_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4653,7 +4794,7 @@ subroutine psb_ls_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_scals - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4664,7 +4805,7 @@ subroutine psb_ls_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4682,11 +4823,151 @@ subroutine psb_ls_scals(d,a,info) end subroutine psb_ls_scals +subroutine psb_ls_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_scalplusidentity + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_scalplusidentity + +subroutine psb_ls_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_spaxpby + implicit none + real(psb_spk_), intent(in) :: alpha + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: beta + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_spaxpby + +function psb_ls_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cmpval + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_cmpval + +function psb_ls_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cmpmat + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + real(psb_spk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_cmpmat + function psb_ls_maxval(a) result(res) use psb_s_mat_mod, psb_protect_name => psb_ls_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -4697,7 +4978,7 @@ function psb_ls_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4717,7 +4998,7 @@ function psb_ls_csnmi(a) result(res) use psb_s_mat_mod, psb_protect_name => psb_ls_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -4727,7 +5008,7 @@ function psb_ls_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4747,7 +5028,7 @@ function psb_ls_csnm1(a) result(res) use psb_s_mat_mod, psb_protect_name => psb_ls_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_) :: res @@ -4757,7 +5038,7 @@ function psb_ls_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4778,7 +5059,7 @@ function psb_ls_rowsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_ls_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4789,7 +5070,7 @@ function psb_ls_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4811,7 +5092,7 @@ function psb_ls_arwsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_ls_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4822,7 +5103,7 @@ function psb_ls_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4845,7 +5126,7 @@ function psb_ls_colsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_ls_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4856,7 +5137,7 @@ function psb_ls_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4879,7 +5160,7 @@ function psb_ls_aclsum(a,info) result(d) use psb_s_mat_mod, psb_protect_name => psb_ls_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a real(psb_spk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4890,7 +5171,7 @@ function psb_ls_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4913,8 +5194,8 @@ subroutine psb_ls_mv_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from_ib - implicit none - + implicit none + class(psb_lsspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4922,15 +5203,15 @@ subroutine psb_ls_mv_from_ib(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_ifmt(b,info) - + end subroutine psb_ls_mv_from_ib - + subroutine psb_ls_cp_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from_ib - implicit none - + implicit none + class(psb_lsspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4945,30 +5226,30 @@ subroutine psb_ls_mv_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to_ib - implicit none - + implicit none + class(psb_lsspmat_type), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_ifmt(b,info) call a%free() end if - + end subroutine psb_ls_mv_to_ib subroutine psb_ls_cp_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to_ib - implicit none + implicit none class(psb_lsspmat_type), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -4981,7 +5262,7 @@ subroutine psb_ls_mv_from_i(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from_i - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -4993,20 +5274,20 @@ subroutine psb_ls_mv_from_i(a,b) call a%free() end if call b%free() - + end subroutine psb_ls_mv_from_i - + subroutine psb_ls_cp_from_i(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from_i - implicit none + implicit none class(psb_lsspmat_type), intent(out) :: a class(psb_sspmat_type), intent(in) :: b integer(psb_ipk_) :: info - + if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_ifmt(b%a,info) @@ -5019,12 +5300,12 @@ subroutine psb_ls_mv_to_i(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to_i - implicit none + implicit none class(psb_lsspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_s_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_ifmt(b%a,info) @@ -5032,28 +5313,24 @@ subroutine psb_ls_mv_to_i(a,b) call b%free() end if call a%free() - + end subroutine psb_ls_mv_to_i subroutine psb_ls_cp_to_i(a,b) use psb_error_mod use psb_const_mod use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to_i - implicit none - + implicit none + class(psb_lsspmat_type), intent(in) :: a class(psb_sspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_s_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_ifmt(b%a,info) else call b%free() end if - + end subroutine psb_ls_cp_to_i - - - - diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 7bca2c7cc..fbbbd83d7 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == ================================== ! ! @@ -45,7 +45,7 @@ subroutine psb_z_base_cp_to_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -69,7 +69,7 @@ subroutine psb_z_base_cp_from_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -94,7 +94,7 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -103,10 +103,10 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -117,12 +117,12 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -136,7 +136,7 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -148,10 +148,10 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_z_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -160,8 +160,8 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -181,7 +181,7 @@ subroutine psb_z_base_mv_to_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -193,17 +193,17 @@ subroutine psb_z_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -218,7 +218,7 @@ subroutine psb_z_base_mv_from_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -229,17 +229,17 @@ subroutine psb_z_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -255,7 +255,7 @@ subroutine psb_z_base_mv_to_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -267,7 +267,7 @@ subroutine psb_z_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_z_coo_sparse_mat) @@ -285,7 +285,7 @@ subroutine psb_z_base_mv_from_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ subroutine psb_z_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_z_coo_sparse_mat) @@ -313,23 +313,23 @@ end subroutine psb_z_base_mv_from_fmt subroutine psb_z_base_clean_zeros(a, info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_clean_zeros - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_z_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_z_base_clean_zeros -subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_a - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -350,11 +350,11 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_z_base_csput_a -subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_v use psb_z_base_vect_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -366,24 +366,24 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() if (ia%is_dev()) call ia%sync() if (ja%is_dev()) call ja%sync() - call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -395,7 +395,7 @@ end subroutine psb_z_base_csput_v subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csgetrow @@ -433,7 +433,7 @@ end subroutine psb_z_base_csgetrow ! subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csgetblk @@ -456,22 +456,22 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -486,19 +486,19 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'z_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -526,7 +526,7 @@ end subroutine psb_z_base_csgetblk subroutine psb_z_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csclip @@ -547,46 +547,46 @@ subroutine psb_z_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -615,7 +615,7 @@ end subroutine psb_z_base_csclip ! subroutine psb_z_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_tril @@ -627,8 +627,8 @@ subroutine psb_z_base_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_z_coo_sparse_mat), optional, intent(out) :: u - - integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk + + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_dpk_), allocatable :: val(:) @@ -640,51 +640,51 @@ subroutine psb_z_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -716,7 +716,7 @@ subroutine psb_z_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -724,8 +724,8 @@ subroutine psb_z_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -738,7 +738,7 @@ subroutine psb_z_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -747,8 +747,8 @@ subroutine psb_z_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -766,7 +766,7 @@ end subroutine psb_z_base_tril subroutine psb_z_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_triu @@ -778,7 +778,7 @@ subroutine psb_z_base_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_z_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k, ibk integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) @@ -791,57 +791,57 @@ subroutine psb_z_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -874,13 +874,13 @@ subroutine psb_z_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -888,7 +888,7 @@ subroutine psb_z_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -897,8 +897,8 @@ subroutine psb_z_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -919,45 +919,45 @@ end subroutine psb_z_base_triu subroutine psb_z_base_clone(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_z_base_clone subroutine psb_z_base_make_nonunit(a) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat) :: tmp - - integer(psb_ipk_) :: i, j, m, n, nz, mnm, info - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + integer(psb_ipk_) :: i, j, m, n, nz, mnm, info + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -974,10 +974,10 @@ subroutine psb_z_base_make_nonunit(a) end subroutine psb_z_base_make_nonunit -subroutine psb_z_base_mold(a,b,info) +subroutine psb_z_base_mold(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mold use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -999,7 +999,7 @@ end subroutine psb_z_base_mold subroutine psb_z_base_transp_2mat(a,b) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1019,11 +1019,11 @@ subroutine psb_z_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1035,7 +1035,7 @@ end subroutine psb_z_base_transp_2mat subroutine psb_z_base_transc_2mat(a,b) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transc_2mat - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b @@ -1055,11 +1055,11 @@ subroutine psb_z_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1071,7 +1071,7 @@ end subroutine psb_z_base_transc_2mat subroutine psb_z_base_transp_1mat(a) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a @@ -1085,12 +1085,12 @@ subroutine psb_z_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1102,7 +1102,7 @@ end subroutine psb_z_base_transp_1mat subroutine psb_z_base_transc_1mat(a) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transc_1mat - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a @@ -1116,12 +1116,12 @@ subroutine psb_z_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -1145,11 +1145,11 @@ end subroutine psb_z_base_transc_1mat ! ! == ================================== -subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmm use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1172,10 +1172,10 @@ subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_z_base_csmm -subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csmv use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1199,10 +1199,10 @@ subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_z_base_csmv -subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_cssm use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1225,10 +1225,10 @@ subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) end subroutine psb_z_base_inner_cssm -subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_cssv use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1251,11 +1251,11 @@ subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) end subroutine psb_z_base_inner_cssv -subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cssm use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1271,7 +1271,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1291,42 +1291,42 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) then + allocate(tmp(nac,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) then do i=1, nac - tmp(i,1:nc) = d(i)*x(i,1:nc) + tmp(i,1:nc) = d(i)*x(i,1:nc) end do end if if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ @@ -1334,21 +1334,21 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - allocate(tmp(nar,nc),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar,nc),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(zone,x,zzero,tmp,info,trans) - if (info == psb_success_)then + if (info == psb_success_)then do i=1, nar - tmp(i,1:nc) = d(i)*tmp(i,1:nc) + tmp(i,1:nc) = d(i)*tmp(i,1:nc) end do end if if (info == psb_success_)& & call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if @@ -1357,13 +1357,13 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_cssm') goto 9999 end if @@ -1378,11 +1378,11 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_z_base_cssm -subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cssv use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1418,58 +1418,58 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (present(d)) then - if (present(scale)) then + if (present(d)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if - allocate(tmp(nac),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call inner_vscal(nac,d,x,tmp) + allocate(tmp(nac),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call inner_vscal(nac,d,x,tmp) if (info == psb_success_)& & call a%inner_spsm(alpha,tmp,beta,y,info,trans) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == zzero) then + if (beta == zzero) then call a%inner_spsm(alpha,x,zzero,y,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,y) else - allocate(tmp(nar),stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + allocate(tmp(nar),stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,zzero,tmp,info,trans) if (info == psb_success_) call inner_vscal1(nar,d,tmp) if (info == psb_success_)& & call psb_geaxpby(nar,zone,tmp,beta,y,info) - if (info == psb_success_) then - deallocate(tmp,stat=info) + if (info == psb_success_) then + deallocate(tmp,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1479,13 +1479,13 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1500,37 +1500,37 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) return contains subroutine inner_vscal(n,d,x,y) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n complex(psb_dpk_), intent(in) :: d(*),x(*) complex(psb_dpk_), intent(out) :: y(*) integer(psb_ipk_) :: i do i=1,n - y(i) = d(i)*x(i) + y(i) = d(i)*x(i) end do end subroutine inner_vscal subroutine inner_vscal1(n,d,x) - implicit none + implicit none integer(psb_ipk_), intent(in) :: n complex(psb_dpk_), intent(in) :: d(*) complex(psb_dpk_), intent(inout) :: x(*) integer(psb_ipk_) :: i do i=1,n - x(i) = d(i)*x(i) + x(i) = d(i)*x(i) end do end subroutine inner_vscal1 end subroutine psb_z_base_cssv -subroutine psb_z_base_scals(d,a,info) +subroutine psb_z_base_scals(d,a,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scals use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1550,12 +1550,55 @@ subroutine psb_z_base_scals(d,a,info) end subroutine psb_z_base_scals +subroutine psb_z_base_scalplusidentity(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: acoo -subroutine psb_z_base_scal(d,a,info,side) + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_scalplusidentity + +subroutine psb_z_base_scal(d,a,info,side) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_scal use psb_error_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1581,7 +1624,7 @@ function psb_z_base_maxval(a) result(res) use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_maxval - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1608,27 +1651,27 @@ function psb_z_base_csnmi(a) result(res) use psb_realloc_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csnmi - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1646,27 +1689,27 @@ function psb_z_base_csnm1(a) result(res) use psb_realloc_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csnm1 - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -1678,7 +1721,7 @@ function psb_z_base_csnm1(a) result(res) end function psb_z_base_csnm1 -subroutine psb_z_base_rowsum(d,a) +subroutine psb_z_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_rowsum @@ -1700,7 +1743,7 @@ subroutine psb_z_base_rowsum(d,a) end subroutine psb_z_base_rowsum -subroutine psb_z_base_arwsum(d,a) +subroutine psb_z_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_arwsum @@ -1722,7 +1765,7 @@ subroutine psb_z_base_arwsum(d,a) end subroutine psb_z_base_arwsum -subroutine psb_z_base_colsum(d,a) +subroutine psb_z_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_colsum @@ -1744,7 +1787,7 @@ subroutine psb_z_base_colsum(d,a) end subroutine psb_z_base_colsum -subroutine psb_z_base_aclsum(d,a) +subroutine psb_z_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_aclsum @@ -1766,12 +1809,12 @@ subroutine psb_z_base_aclsum(d,a) end subroutine psb_z_base_aclsum -subroutine psb_z_base_get_diag(a,d,info) +subroutine psb_z_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_get_diag - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1791,15 +1834,153 @@ subroutine psb_z_base_get_diag(a,d,info) end subroutine psb_z_base_get_diag +subroutine psb_z_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_spaxpby + + complex(psb_dpk_), intent(in) :: alpha + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: beta + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_z_base_spaxpby + +function psb_z_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cmpval + + class(psb_z_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_z_base_cmpval + +function psb_z_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cmpmat + + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: acoo + + call a%cp_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_z_base_cmpmat ! == ================================== ! ! ! ! Computational routines for z_VECT -! variables. If the actual data type is -! a "normal" one, these are sufficient. -! +! variables. If the actual data type is +! a "normal" one, these are sufficient. +! ! ! ! @@ -1807,11 +1988,11 @@ end subroutine psb_z_base_get_diag -subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_base_vect_mv - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x @@ -1820,7 +2001,7 @@ subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) character, optional, intent(in) :: trans ! For the time being we just throw everything back - ! onto the normal routines. + ! onto the normal routines. call x%sync() call y%sync() call a%spmm(alpha,x%v,beta,y%v,info,trans) @@ -1832,7 +2013,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_z_base_vect_mod use psb_error_mod use psb_string_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x,y @@ -1869,54 +2050,54 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - call x%sync() + call x%sync() call y%sync() - if (present(d)) then + if (present(d)) then call d%sync() - if (present(scale)) then + if (present(scale)) then scale_ = scale else scale_ = 'L' end if - if (psb_toupper(scale_) == 'R') then + if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call tmpv%mlt(zone,d%v(1:nac),x,zzero,info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call tmpv%mlt(zone,d%v(1:nac),x,zzero,info) if (info == psb_success_)& & call a%inner_spsm(alpha,tmpv,beta,y,info,trans) - if (info == psb_success_) then + if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if - else if (psb_toupper(scale_) == 'L') then + else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if - if (beta == zzero) then + if (beta == zzero) then call a%inner_spsm(alpha,x,zzero,y,info,trans) if (info == psb_success_) call y%mlt(d%v(1:nar),info) else allocate(tmpv, mold=y,stat=info) - if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info /= psb_success_) info = psb_err_alloc_dealloc_ if (info == psb_success_)& & call a%inner_spsm(alpha,x,zzero,tmpv,info,trans) @@ -1925,7 +2106,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) & call y%axpby(nar,zone,tmpv,beta,info) if (info == psb_success_) then call tmpv%free(info) - if (info == psb_success_) deallocate(tmpv,stat=info) + if (info == psb_success_) deallocate(tmpv,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ end if end if @@ -1935,13 +2116,13 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if - else - ! Scale is ignored in this case + else + ! Scale is ignored in this case call a%inner_spsm(alpha,x,beta,y,info,trans) end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1958,12 +2139,12 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_z_base_vect_cssv -subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_inner_vect_sv use psb_error_mod use psb_string_mod use psb_z_base_vect_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x, y @@ -1977,10 +2158,10 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) + call a%inner_spsm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='inner_spsm') goto 9999 end if @@ -1988,7 +2169,7 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) call psb_erractionrestore(err_act) return - + 9999 call psb_error_handler(err_act) return @@ -2000,7 +2181,7 @@ subroutine psb_z_base_cp_to_lcoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2009,22 +2190,22 @@ subroutine psb_z_base_cp_to_lcoo(a,b,info) character(len=20) :: name='to_lcoo' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_lcoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2038,7 +2219,7 @@ subroutine psb_z_base_cp_from_lcoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2047,22 +2228,22 @@ subroutine psb_z_base_cp_from_lcoo(a,b,info) character(len=20) :: name='from_coo' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_lcoo(b,info) + call tmp%cp_from_lcoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2076,7 +2257,7 @@ subroutine psb_z_base_cp_to_lfmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2086,10 +2267,10 @@ subroutine psb_z_base_cp_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: icoo type(psb_lz_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2102,12 +2283,12 @@ subroutine psb_z_base_cp_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2121,7 +2302,7 @@ subroutine psb_z_base_cp_from_lfmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2133,10 +2314,10 @@ subroutine psb_z_base_cp_from_lfmt(a,b,info) type(psb_lz_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_lz_coo_sparse_mat) call a%cp_from_lcoo(b,info) @@ -2146,8 +2327,8 @@ subroutine psb_z_base_cp_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2166,7 +2347,7 @@ subroutine psb_z_base_mv_to_lcoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2178,17 +2359,17 @@ subroutine psb_z_base_mv_to_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2202,7 +2383,7 @@ subroutine psb_z_base_mv_from_lcoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_lcoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2213,17 +2394,17 @@ subroutine psb_z_base_mv_from_lcoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_lcoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2238,7 +2419,7 @@ subroutine psb_z_base_mv_to_lfmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2248,10 +2429,10 @@ subroutine psb_z_base_mv_to_lfmt(a,b,info) logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: icoo type(psb_lz_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2264,12 +2445,12 @@ subroutine psb_z_base_mv_to_lfmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2283,7 +2464,7 @@ subroutine psb_z_base_mv_from_lfmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_lfmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2295,10 +2476,10 @@ subroutine psb_z_base_mv_from_lfmt(a,b,info) type(psb_lz_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_lz_coo_sparse_mat) call a%mv_from_lcoo(b,info) @@ -2308,8 +2489,8 @@ subroutine psb_z_base_mv_from_lfmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2343,7 +2524,7 @@ subroutine psb_lz_base_cp_to_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2367,7 +2548,7 @@ subroutine psb_lz_base_cp_from_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2392,7 +2573,7 @@ subroutine psb_lz_base_cp_to_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2401,10 +2582,10 @@ subroutine psb_lz_base_cp_to_fmt(a,b,info) character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_lz_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -2415,12 +2596,12 @@ subroutine psb_lz_base_cp_to_fmt(a,b,info) call a%cp_to_coo(tmp,info) if (info == psb_success_) call b%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2434,7 +2615,7 @@ subroutine psb_lz_base_cp_from_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2446,10 +2627,10 @@ subroutine psb_lz_base_cp_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_lz_coo_sparse_mat) call a%cp_from_coo(b,info) @@ -2458,8 +2639,8 @@ subroutine psb_lz_base_cp_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -2479,7 +2660,7 @@ subroutine psb_lz_base_mv_to_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2491,17 +2672,17 @@ subroutine psb_lz_base_mv_to_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -2516,7 +2697,7 @@ subroutine psb_lz_base_mv_from_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_coo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2527,17 +2708,17 @@ subroutine psb_lz_base_mv_from_coo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_coo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -2552,7 +2733,7 @@ subroutine psb_lz_base_mv_to_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2564,7 +2745,7 @@ subroutine psb_lz_base_mv_to_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_lz_coo_sparse_mat) @@ -2582,7 +2763,7 @@ subroutine psb_lz_base_mv_from_fmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_fmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2594,7 +2775,7 @@ subroutine psb_lz_base_mv_from_fmt(a,b,info) ! ! Default implementation - ! + ! info = psb_success_ select type(b) type is (psb_lz_coo_sparse_mat) @@ -2610,23 +2791,23 @@ end subroutine psb_lz_base_mv_from_fmt subroutine psb_lz_base_clean_zeros(a, info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clean_zeros - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! type(psb_lz_coo_sparse_mat) :: tmpcoo call a%mv_to_coo(tmpcoo,info) - if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call tmpcoo%clean_zeros(info) if (info == 0) call a%mv_from_coo(tmpcoo,info) - + end subroutine psb_lz_base_clean_zeros -subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -2647,11 +2828,11 @@ subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_lz_base_csput_a -subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v use psb_z_base_vect_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_vect_type), intent(inout) :: val class(psb_l_base_vect_type), intent(inout) :: ia, ja @@ -2664,10 +2845,10 @@ subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then if (a%is_dev()) call a%sync() if (val%is_dev()) call val%sync() @@ -2677,11 +2858,11 @@ subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= 0) then + if (info /= 0) then call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -2693,7 +2874,7 @@ end subroutine psb_lz_base_csput_v subroutine psb_lz_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetrow @@ -2733,7 +2914,7 @@ end subroutine psb_lz_base_csgetrow ! subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetblk @@ -2757,22 +2938,22 @@ subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_=rscale else rscale_=.false. end if - if (present(cscale)) then + if (present(cscale)) then cscale_=cscale else cscale_=.false. @@ -2787,19 +2968,19 @@ subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& else jmax_ = a%get_ncols() endif - - if (append_.and.(rscale_.or.cscale_)) then + + if (append_.and.(rscale_.or.cscale_)) then write(psb_err_unit,*) & & 'lz_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' end if - if (rscale_) then + if (rscale_) then call b%set_nrows(imax-imin+1) else call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) end if - if (cscale_) then + if (cscale_) then call b%set_ncols(jmax_-jmin_+1) else call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) @@ -2827,7 +3008,7 @@ end subroutine psb_lz_base_csgetblk subroutine psb_lz_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csclip @@ -2849,46 +3030,46 @@ subroutine psb_lz_base_csclip(a,b,info,& info = psb_success_ nzin = 0 - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = a%get_nrows() ! Should this be imax_ ?? + else + mb = a%get_nrows() ! Should this be imax_ ?? endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = a%get_ncols() ! Should this be jmax_ ?? + else + nb = a%get_ncols() ! Should this be jmax_ ?? endif call b%allocate(mb,nb) call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& @@ -2917,7 +3098,7 @@ end subroutine psb_lz_base_csclip ! subroutine psb_lz_base_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_tril @@ -2929,9 +3110,9 @@ subroutine psb_lz_base_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lz_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_lpk_), allocatable :: ia(:), ja(:) complex(psb_dpk_), allocatable :: val(:) @@ -2943,51 +3124,51 @@ subroutine psb_lz_base_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif @@ -3019,7 +3200,7 @@ subroutine psb_lz_base_tril(a,l,info,& end if end do end do - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -3027,8 +3208,8 @@ subroutine psb_lz_base_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >= -1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if @@ -3041,7 +3222,7 @@ subroutine psb_lz_base_tril(a,l,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call l%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call l%fix(info) @@ -3050,8 +3231,8 @@ subroutine psb_lz_base_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -3069,7 +3250,7 @@ end subroutine psb_lz_base_tril subroutine psb_lz_base_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_triu @@ -3081,7 +3262,7 @@ subroutine psb_lz_base_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lz_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -3095,57 +3276,57 @@ subroutine psb_lz_base_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -3178,13 +3359,13 @@ subroutine psb_lz_base_triu(a,u,info,& if (rscale_) & & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & - & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - if ((diag_ <=1).and.(imin_ == jmin_)) then + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + if ((diag_ <=1).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if else - nzin = u%get_nzeros() + nzin = u%get_nzeros() do i=imin_,imax_ k = max(jmin_,i+diag_) call a%csget(i,i,nzout,u%ia,u%ja,u%val,info,& @@ -3192,7 +3373,7 @@ subroutine psb_lz_base_triu(a,u,info,& & nzin=nzin) if (info /= psb_success_) goto 9999 call u%set_nzeros(nzin+nzout) - nzin = nzin+nzout + nzin = nzin+nzout end do end if call u%fix(info) @@ -3201,8 +3382,8 @@ subroutine psb_lz_base_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -3223,46 +3404,46 @@ end subroutine psb_lz_base_triu subroutine psb_lz_base_clone(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clone use psb_error_mod - implicit none - + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info - info = 0 + info = 0 if (allocated(b)) then call b%free() deallocate(b, stat=info) end if - if (info /= 0) then + if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ! Do not use SOURCE allocation: this makes sure that - ! memory allocated elsewhere is treated properly. + ! memory allocated elsewhere is treated properly. allocate(b,mold=a,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call b%cp_from_fmt(a, info) - + if (info == psb_success_) call b%cp_from_fmt(a, info) + end subroutine psb_lz_base_clone subroutine psb_lz_base_make_nonunit(a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_make_nonunit use psb_error_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a type(psb_lz_coo_sparse_mat) :: tmp - + integer(psb_ipk_) :: info integer(psb_lpk_) :: i, j, m, n, nz, mnm - if (a%is_unit()) then - call a%mv_to_coo(tmp,info) + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) if (info /= 0) return m = tmp%get_nrows() n = tmp%get_ncols() - mnm = min(m,n) + mnm = min(m,n) nz = tmp%get_nzeros() call tmp%reallocate(nz+mnm) do i=1, mnm @@ -3279,10 +3460,10 @@ subroutine psb_lz_base_make_nonunit(a) end subroutine psb_lz_base_make_nonunit -subroutine psb_lz_base_mold(a,b,info) +subroutine psb_lz_base_mold(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mold use psb_error_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3304,7 +3485,7 @@ end subroutine psb_lz_base_mold subroutine psb_lz_base_transp_2mat(a,b) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_2mat use psb_error_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3324,11 +3505,11 @@ subroutine psb_lz_base_transp_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3340,7 +3521,7 @@ end subroutine psb_lz_base_transp_2mat subroutine psb_lz_base_transc_2mat(a,b) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_2mat - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_lbase_sparse_mat), intent(out) :: b @@ -3360,11 +3541,11 @@ subroutine psb_lz_base_transc_2mat(a,b) class default info = psb_err_invalid_dynamic_type_ end select - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3376,7 +3557,7 @@ end subroutine psb_lz_base_transc_2mat subroutine psb_lz_base_transp_1mat(a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_1mat use psb_error_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a @@ -3390,12 +3571,12 @@ subroutine psb_lz_base_transp_1mat(a) if (info == psb_success_) call tmp%transp() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3407,7 +3588,7 @@ end subroutine psb_lz_base_transp_1mat subroutine psb_lz_base_transc_1mat(a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_1mat - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a @@ -3421,12 +3602,12 @@ subroutine psb_lz_base_transc_1mat(a) if (info == psb_success_) call tmp%transc() if (info == psb_success_) call a%mv_from_coo(tmp,info) - if (info /= psb_success_) then - info = psb_err_missing_override_method_ + if (info /= psb_success_) then + info = psb_err_missing_override_method_ call psb_errpush(info,name,a_err=a%get_fmt()) goto 9999 end if - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return @@ -3436,10 +3617,10 @@ subroutine psb_lz_base_transc_1mat(a) end subroutine psb_lz_base_transc_1mat -subroutine psb_lz_base_scals(d,a,info) +subroutine psb_lz_base_scals(d,a,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scals use psb_error_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3459,10 +3640,55 @@ subroutine psb_lz_base_scals(d,a,info) end subroutine psb_lz_base_scals -subroutine psb_lz_base_scal(d,a,info,side) +subroutine psb_lz_base_scalplusidentity(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scalplusidentity + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_scalplusidentity' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%scalpid(d,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='scalpid') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_error_handler(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_scalplusidentity + +subroutine psb_lz_base_scal(d,a,info,side) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scal use psb_error_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3488,7 +3714,7 @@ function psb_lz_base_maxval(a) result(res) use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_maxval - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3514,27 +3740,27 @@ function psb_lz_base_csnmi(a) result(res) use psb_realloc_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnmi - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_nrows(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%arwsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3551,27 +3777,27 @@ function psb_lz_base_csnm1(a) result(res) use psb_realloc_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnm1 - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' - real(psb_dpk_), allocatable :: vt(:) - + real(psb_dpk_), allocatable :: vt(:) + logical, parameter :: debug=.false. call psb_erractionsave(err_act) res = dzero - call psb_realloc(a%get_ncols(),vt,info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if call a%aclsum(vt) - res = maxval(vt) + res = maxval(vt) call psb_erractionrestore(err_act) return @@ -3582,7 +3808,7 @@ function psb_lz_base_csnm1(a) result(res) end function psb_lz_base_csnm1 -subroutine psb_lz_base_rowsum(d,a) +subroutine psb_lz_base_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_rowsum @@ -3604,7 +3830,7 @@ subroutine psb_lz_base_rowsum(d,a) end subroutine psb_lz_base_rowsum -subroutine psb_lz_base_arwsum(d,a) +subroutine psb_lz_base_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_arwsum @@ -3626,7 +3852,7 @@ subroutine psb_lz_base_arwsum(d,a) end subroutine psb_lz_base_arwsum -subroutine psb_lz_base_colsum(d,a) +subroutine psb_lz_base_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_colsum @@ -3648,7 +3874,7 @@ subroutine psb_lz_base_colsum(d,a) end subroutine psb_lz_base_colsum -subroutine psb_lz_base_aclsum(d,a) +subroutine psb_lz_base_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_aclsum @@ -3670,12 +3896,151 @@ subroutine psb_lz_base_aclsum(d,a) end subroutine psb_lz_base_aclsum -subroutine psb_lz_base_get_diag(a,d,info) +subroutine psb_lz_base_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_spaxpby + + complex(psb_dpk_), intent(in) :: alpha + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: beta + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxpby' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: acoo + + call psb_erractionsave(err_act) + if((a%get_ncols() /= b%get_ncols()).or.(a%get_nrows() /= b%get_nrows())) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call acoo%spaxpby(alpha,beta,b,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='spaxby') + goto 9999 + end if + + call acoo%mv_to_fmt(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_fmt') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lz_base_spaxpby + +function psb_lz_base_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cmpval + + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + res = acoo%spcmp(val,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpval') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lz_base_cmpval + +function psb_lz_base_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cmpmat + + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: acoo + + call a%mv_to_coo(acoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + ! Fix the indexes + call acoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + + res = acoo%spcmp(b,tol,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cmpmat') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lz_base_cmpmat + +subroutine psb_lz_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_get_diag - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3701,7 +4066,7 @@ subroutine psb_lz_base_cp_to_icoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3710,22 +4075,22 @@ subroutine psb_lz_base_cp_to_icoo(a,b,info) character(len=20) :: name='to_coo' logical, parameter :: debug=.false. type(psb_lz_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) call a%cp_to_coo(tmp,info) if (info == psb_success_) call tmp%mv_to_icoo(b,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3739,7 +4104,7 @@ subroutine psb_lz_base_cp_from_icoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3748,22 +4113,22 @@ subroutine psb_lz_base_cp_from_icoo(a,b,info) character(len=20) :: name='from_icoo' logical, parameter :: debug=.false. type(psb_lz_coo_sparse_mat) :: tmp - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - call tmp%cp_from_icoo(b,info) + call tmp%cp_from_icoo(b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) - - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3778,7 +4143,7 @@ subroutine psb_lz_base_cp_to_ifmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3788,10 +4153,10 @@ subroutine psb_lz_base_cp_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: icoo type(psb_lz_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3804,12 +4169,12 @@ subroutine psb_lz_base_cp_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3823,7 +4188,7 @@ subroutine psb_lz_base_cp_from_ifmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -3835,10 +4200,10 @@ subroutine psb_lz_base_cp_from_ifmt(a,b,info) type(psb_lz_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_z_coo_sparse_mat) call a%cp_from_icoo(b,info) @@ -3848,8 +4213,8 @@ subroutine psb_lz_base_cp_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -3868,7 +4233,7 @@ subroutine psb_lz_base_mv_to_icoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3880,17 +4245,17 @@ subroutine psb_lz_base_mv_to_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_to_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to coo') goto 9999 end if call a%free() - + call psb_erractionrestore(err_act) return @@ -3905,7 +4270,7 @@ subroutine psb_lz_base_mv_from_icoo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_icoo use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3916,17 +4281,17 @@ subroutine psb_lz_base_mv_from_icoo(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - - call a%cp_from_icoo(b,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='from coo') goto 9999 end if call b%free() - + call psb_erractionrestore(err_act) return @@ -3942,7 +4307,7 @@ subroutine psb_lz_base_mv_to_ifmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3952,10 +4317,10 @@ subroutine psb_lz_base_mv_to_ifmt(a,b,info) logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: icoo type(psb_lz_coo_sparse_mat) :: lcoo - + ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) @@ -3968,12 +4333,12 @@ subroutine psb_lz_base_mv_to_ifmt(a,b,info) if (info == psb_success_) call b%mv_from_coo(icoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if - + call psb_erractionrestore(err_act) return @@ -3987,7 +4352,7 @@ subroutine psb_lz_base_mv_from_ifmt(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_ifmt use psb_error_mod use psb_realloc_mod - implicit none + implicit none class(psb_lz_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3999,10 +4364,10 @@ subroutine psb_lz_base_mv_from_ifmt(a,b,info) type(psb_lz_coo_sparse_mat) :: lcoo ! ! Default implementation - ! + ! info = psb_success_ call psb_erractionsave(err_act) - + select type(b) type is (psb_z_coo_sparse_mat) call a%mv_from_icoo(b,info) @@ -4012,8 +4377,8 @@ subroutine psb_lz_base_mv_from_ifmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(lcoo,info) end select - if (info /= psb_success_) then - info = psb_err_from_subroutine_ + if (info /= psb_success_) then + info = psb_err_from_subroutine_ call psb_errpush(info,name, a_err='to/from coo') goto 9999 end if @@ -4026,5 +4391,3 @@ subroutine psb_lz_base_mv_from_ifmt(a,b,info) return end subroutine psb_lz_base_mv_from_ifmt - - diff --git a/base/serial/impl/psb_z_coo_impl.F90 b/base/serial/impl/psb_z_coo_impl.F90 index da8f2a1a1..2da382963 100644 --- a/base/serial/impl/psb_z_coo_impl.F90 +++ b/base/serial/impl/psb_z_coo_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! -subroutine psb_z_coo_get_diag(a,d,info) +! +! +subroutine psb_z_coo_get_diag(a,d,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -47,19 +47,19 @@ subroutine psb_z_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = zone + if (a%is_unit()) then + d(1:mnm) = zone else d(1:mnm) = zzero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -74,12 +74,12 @@ subroutine psb_z_coo_get_diag(a,d,info) end subroutine psb_z_coo_get_diag -subroutine psb_z_coo_scal(d,a,info,side) +subroutine psb_z_coo_scal(d,a,info,side) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -88,44 +88,44 @@ subroutine psb_z_coo_scal(d,a,info,side) integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -143,11 +143,11 @@ subroutine psb_z_coo_scal(d,a,info,side) end subroutine psb_z_coo_scal -subroutine psb_z_coo_scals(d,a,info) +subroutine psb_z_coo_scals(d,a,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -160,13 +160,14 @@ subroutine psb_z_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if do i=1,a%get_nzeros() a%val(i) = a%val(i) * d enddo + call a%set_host() call psb_erractionrestore(err_act) @@ -178,12 +179,207 @@ subroutine psb_z_coo_scals(d,a,info) end subroutine psb_z_coo_scals +subroutine psb_z_coo_scalplusidentity(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info -subroutine psb_z_coo_reallocate_nz(nz,a) + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + zone + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_coo_scalplusidentity + +subroutine psb_z_coo_spaxpby(alpha,a,beta,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_coo_spaxpby' + type(psb_z_coo_sparse_mat) :: tcoo,bcoo + integer(psb_ipk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_z_coo_spaxpby + +function psb_z_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cmpval + + class(psb_z_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_z_coo_cmpval + +function psb_z_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cmpmat + + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_ipk_) :: nza, nzb, nzl, M, N + type(psb_z_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-done)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_z_coo_cmpmat + +subroutine psb_z_coo_reallocate_nz(nz,a) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -197,7 +393,7 @@ subroutine psb_z_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -211,11 +407,11 @@ subroutine psb_z_coo_reallocate_nz(nz,a) end subroutine psb_z_coo_reallocate_nz -subroutine psb_z_coo_ensure_size(nz,a) +subroutine psb_z_coo_ensure_size(nz,a) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -229,7 +425,7 @@ subroutine psb_z_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -243,10 +439,10 @@ subroutine psb_z_coo_ensure_size(nz,a) end subroutine psb_z_coo_ensure_size -subroutine psb_z_coo_mold(a,b,info) +subroutine psb_z_coo_mold(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_mold use psb_error_mod - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -255,16 +451,16 @@ subroutine psb_z_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_z_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -279,9 +475,9 @@ end subroutine psb_z_coo_mold subroutine psb_z_coo_reinit(a,clear) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -293,17 +489,17 @@ subroutine psb_z_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = zzero call a%set_host() call a%set_upd() @@ -328,7 +524,7 @@ subroutine psb_z_coo_trim(a) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' @@ -342,7 +538,7 @@ subroutine psb_z_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -355,13 +551,13 @@ end subroutine psb_z_coo_trim subroutine psb_z_coo_clean_zeros(a, info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_clean_zeros - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -372,14 +568,14 @@ subroutine psb_z_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_z_coo_clean_zeros subroutine psb_z_coo_clean_negidx(a,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_clean_negidx - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -387,13 +583,13 @@ subroutine psb_z_coo_clean_negidx(a,info) integer(psb_ipk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_z_coo_clean_negidx -subroutine psb_z_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +subroutine psb_z_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_clean_negidx_inner - implicit none + implicit none integer(psb_ipk_), intent(in) :: nzin integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) @@ -402,24 +598,24 @@ subroutine psb_z_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_ipk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_z_coo_clean_negidx_inner -subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -429,22 +625,22 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -452,7 +648,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(izero) @@ -464,7 +660,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -479,10 +675,10 @@ end subroutine psb_z_coo_allocate_mnnz subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -490,12 +686,12 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -504,26 +700,26 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_z_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -538,7 +734,7 @@ end subroutine psb_z_coo_print function psb_z_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_nz_row + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_nz_row implicit none class(psb_z_coo_sparse_mat), intent(in) :: a @@ -547,39 +743,39 @@ function psb_z_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: nzin_, nza,ip,jp,i,k if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -587,12 +783,12 @@ function psb_z_coo_get_nz_row(idx,a) result(res) end function psb_z_coo_get_nz_row -subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cssm - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -611,14 +807,14 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif if (a%is_dev()) call a%sync() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -643,7 +839,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) nnz = a%get_nzeros() if (alpha == zzero) then @@ -659,15 +855,15 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == zzero) then + if (beta == zzero) then call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & m,nc,nnz,a%ia,a%ja,a%val,& & x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -697,11 +893,11 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,& - & ia,ja,val,x,ldx,y,ldy,info) - implicit none + & ia,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*) complex(psb_dpk_), intent(in) :: val(*), x(ldx,*) @@ -719,7 +915,7 @@ contains end if - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if @@ -727,14 +923,14 @@ contains nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = zzero - do + do if (j > nnz) exit if (ia(j) > i) exit acc(1:nc) = acc(1:nc) + val(j)*y(ja(j),1:nc) @@ -742,14 +938,14 @@ contains end do y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc(1:nc) = zzero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j + 1 exit @@ -760,12 +956,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = zzero - do + do i=nr, 1, -1 + acc(1:nc) = zzero + do if (j < 1) exit if (ia(j) < i) exit acc(1:nc) = acc(1:nc) + val(j)*x(ja(j),1:nc) @@ -774,15 +970,15 @@ contains y(i,1:nc) = x(i,1:nc) - acc(1:nc) end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc(1:nc) = zzero - do + do i=nr, 1, -1 + acc(1:nc) = zzero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = (x(i,1:nc) - acc(1:nc))/val(j) j = j - 1 exit @@ -795,68 +991,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) /val(j) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc(1:nc) j = j + 1 end do end do @@ -864,68 +1060,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc(1:nc) = y(i,1:nc) + acc(1:nc) = y(i,1:nc) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) - j = j - 1 + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / conjg(val(j)) j = j - 1 end if - acc(1:nc) = y(i,1:nc) - do + acc(1:nc) = y(i,1:nc) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i,1:nc) = y(i,1:nc) / conjg(val(j)) j = j + 1 end if acc(1:nc) = y(i,1:nc) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc(1:nc) j = j + 1 end do end do @@ -940,12 +1136,12 @@ end subroutine psb_z_coo_cssm -subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cssv - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -969,7 +1165,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -989,7 +1185,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1009,20 +1205,20 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) return end if - if (beta == zzero) then + if (beta == zzero) then call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,y,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if do i = 1, m y(i) = alpha*y(i) end do - else - allocate(tmp(m), stat=info) - if (info /= psb_success_) then + else + allocate(tmp(m), stat=info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') goto 9999 @@ -1031,7 +1227,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_by_rows(),& & a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,& & x,tmp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 end if @@ -1047,11 +1243,11 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,& - & ia,ja,val,x,y,info) - implicit none + & ia,ja,val,x,y,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit,sorted integer(psb_ipk_), intent(in) :: nr,nz,ia(*),ja(*) complex(psb_dpk_), intent(in) :: val(*), x(*) @@ -1062,21 +1258,21 @@ contains complex(psb_dpk_) :: acc info = psb_success_ - if (.not.sorted) then + if (.not.sorted) then info = psb_err_invalid_mat_state_ return end if nnz = nz - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = 1 do i=1, nr acc = zzero - do + do if (j > nnz) exit if (ia(j) > i) exit acc = acc + val(j)*y(ja(j)) @@ -1084,14 +1280,14 @@ contains end do y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr acc = zzero - do + do if (j > nnz) exit if (ia(j) > i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j + 1 exit @@ -1102,12 +1298,12 @@ contains end do end if - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = nnz - do i=nr, 1, -1 - acc = zzero - do + do i=nr, 1, -1 + acc = zzero + do if (j < 1) exit if (ia(j) < i) exit acc = acc + val(j)*y(ja(j)) @@ -1116,15 +1312,15 @@ contains y(i) = x(i) - acc end do - else if (.not.unit) then + else if (.not.unit) then j = nnz - do i=nr, 1, -1 - acc = zzero - do + do i=nr, 1, -1 + acc = zzero + do if (j < 1) exit if (ia(j) < i) exit - if (ja(j) == i) then + if (ja(j) == i) then y(i) = (x(i) - acc)/val(j) j = j - 1 exit @@ -1137,68 +1333,68 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc - j = j - 1 + y(jc) = y(jc) - val(j)*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /val(j) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - val(j)*acc + y(jc) = y(jc) - val(j)*acc j = j + 1 end do end do @@ -1206,68 +1402,68 @@ contains end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i) = x(i) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then j = nnz do i=nr, 1, -1 - acc = y(i) + acc = y(i) do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc - j = j - 1 + y(jc) = y(jc) - conjg(val(j))*acc + j = j - 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = nnz do i=nr, 1, -1 - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /conjg(val(j)) j = j - 1 end if - acc = y(i) - do + acc = y(i) + do if (j < 1) exit if (ia(j) < i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc + y(jc) = y(jc) - conjg(val(j))*acc j = j - 1 end do end do - else if (.not.lower) then - if (unit) then + else if (.not.lower) then + if (unit) then j = 1 do i=1, nr acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc + y(jc) = y(jc) - conjg(val(j))*acc j = j + 1 end do end do - else if (.not.unit) then + else if (.not.unit) then j = 1 do i=1, nr - if (ja(j) == i) then + if (ja(j) == i) then y(i) = y(i) /conjg(val(j)) j = j + 1 end if acc = y(i) - do + do if (j > nnz) exit if (ia(j) > i) exit jc = ja(j) - y(jc) = y(jc) - conjg(val(j))*acc + y(jc) = y(jc) - conjg(val(j))*acc j = j + 1 end do end do @@ -1281,12 +1477,12 @@ contains end subroutine psb_z_coo_cssv -subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csmv - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) @@ -1305,7 +1501,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1323,7 +1519,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1354,8 +1550,8 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == zzero) then do i = 1, min(m,n) y(i) = alpha*x(i) @@ -1364,7 +1560,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) y(i) = zzero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i) = beta*y(i) + alpha*x(i) end do do i = min(m,n)+1, m @@ -1386,28 +1582,28 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) end if - if ((.not.tra).and.(.not.ctra)) then + if ((.not.tra).and.(.not.ctra)) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = zzero - do - if (i>nnz) then + do + if (i>nnz) then y(ir) = y(ir) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir) = y(ir) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = zzero endif acc = acc + a%val(i) * x(a%ja(i)) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == zone) then i = 1 @@ -1425,7 +1621,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - a%val(i)*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1435,7 +1631,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) end if !.....end testing on alpha - else if (ctra) then + else if (ctra) then if (alpha == zone) then i = 1 @@ -1453,7 +1649,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) y(ir) = y(ir) - conjg(a%val(i))*x(jc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1475,12 +1671,12 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_z_coo_csmv -subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) use psb_const_mod use psb_error_mod use psb_string_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csmm - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1499,7 +1695,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) call psb_erractionsave(err_act) - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1518,7 +1714,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -1558,8 +1754,8 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) end do endif return - else - if (a%is_unit()) then + else + if (a%is_unit()) then if (beta == zzero) then do i = 1, min(m,n) y(i,1:nc) = alpha*x(i,1:nc) @@ -1568,7 +1764,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) y(i,1:nc) = zzero enddo else - do i = 1, min(m,n) + do i = 1, min(m,n) y(i,1:nc) = beta*y(i,1:nc) + alpha*x(i,1:nc) end do do i = min(m,n)+1, m @@ -1590,28 +1786,28 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) end if - if (.not.tra) then + if (.not.tra) then i = 1 j = i - if (nnz > 0) then - ir = a%ia(1) + if (nnz > 0) then + ir = a%ia(1) acc = zzero - do - if (i>nnz) then + do + if (i>nnz) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc exit endif - if (a%ia(i) /= ir) then + if (a%ia(i) /= ir) then y(ir,1:nc) = y(ir,1:nc) + alpha * acc - ir = a%ia(i) + ir = a%ia(i) acc = zzero endif acc = acc + a%val(i) * x(a%ja(i),1:nc) - i = i + 1 + i = i + 1 enddo end if - else if (tra) then + else if (tra) then if (alpha == zone) then i = 1 @@ -1629,7 +1825,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - a%val(i)*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1657,7 +1853,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) y(ir,1:nc) = y(ir,1:nc) - conjg(a%val(i))*x(jc,1:nc) enddo - else + else do i=1,nnz ir = a%ja(i) @@ -1681,7 +1877,7 @@ end subroutine psb_z_coo_csmm function psb_z_coo_maxval(a) result(res) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_maxval - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1691,13 +1887,13 @@ function psb_z_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1707,7 +1903,7 @@ end function psb_z_coo_maxval function psb_z_coo_csnmi(a) result(res) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csnmi - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1724,15 +1920,15 @@ function psb_z_coo_csnmi(a) result(res) res = dzero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = dzero - do while (i<=nnz) + res = dzero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -1747,7 +1943,7 @@ function psb_z_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = done else vt = dzero @@ -1759,7 +1955,7 @@ function psb_z_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_z_coo_csnmi @@ -1768,7 +1964,7 @@ function psb_z_coo_csnm1(a) result(res) use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csnm1 - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1787,7 +1983,7 @@ function psb_z_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = done else vt = dzero @@ -1803,7 +1999,7 @@ function psb_z_coo_csnm1(a) result(res) end function psb_z_coo_csnm1 -subroutine psb_z_coo_rowsum(d,a) +subroutine psb_z_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_rowsum @@ -1823,13 +2019,13 @@ subroutine psb_z_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = zone else d = zzero @@ -1843,7 +2039,7 @@ subroutine psb_z_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1851,7 +2047,7 @@ subroutine psb_z_coo_rowsum(d,a) end subroutine psb_z_coo_rowsum -subroutine psb_z_coo_arwsum(d,a) +subroutine psb_z_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_arwsum @@ -1870,13 +2066,13 @@ subroutine psb_z_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1889,7 +2085,7 @@ subroutine psb_z_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1897,7 +2093,7 @@ subroutine psb_z_coo_arwsum(d,a) end subroutine psb_z_coo_arwsum -subroutine psb_z_coo_colsum(d,a) +subroutine psb_z_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_colsum @@ -1916,13 +2112,13 @@ subroutine psb_z_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = zone else d = zzero @@ -1936,7 +2132,7 @@ subroutine psb_z_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1944,7 +2140,7 @@ subroutine psb_z_coo_colsum(d,a) end subroutine psb_z_coo_colsum -subroutine psb_z_coo_aclsum(d,a) +subroutine psb_z_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_aclsum @@ -1963,14 +2159,14 @@ subroutine psb_z_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1981,10 +2177,10 @@ subroutine psb_z_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -2009,7 +2205,7 @@ end subroutine psb_z_coo_aclsum subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2026,7 +2222,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2054,22 +2250,22 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2078,12 +2274,12 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2127,19 +2323,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2154,13 +2350,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2178,31 +2374,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -2211,7 +2407,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -2219,8 +2415,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -2233,12 +2429,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2250,11 +2446,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -2268,7 +2464,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -2277,12 +2473,12 @@ end subroutine psb_z_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2327,27 +2523,27 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2356,12 +2552,12 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2409,19 +2605,19 @@ contains nza = a%get_nzeros() irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -2436,13 +2632,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -2460,34 +2656,34 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -2495,10 +2691,10 @@ contains end if enddo call psb_z_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -2507,7 +2703,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -2516,27 +2712,27 @@ contains nrd = max(a%get_nrows(),1) nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return end if - - if (present(iren)) then - k = 0 + + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - end if + end if end if val(nzin_+k) = a%val(i) ia(nzin_+k) = iren(a%ia(i)) @@ -2544,14 +2740,14 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) @@ -2573,12 +2769,12 @@ contains end subroutine psb_z_coo_csgetrow -subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csput_a - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -2590,30 +2786,30 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) character(len=20) :: name='z_coo_csput_a_impl' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -2624,13 +2820,13 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -2641,22 +2837,22 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call z_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2677,7 +2873,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_ipk_), intent(in) :: ia(:),ja(:) @@ -2688,11 +2884,11 @@ contains integer(psb_ipk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -2708,7 +2904,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2726,13 +2922,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2744,18 +2940,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2767,7 +2963,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2781,18 +2977,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -2804,7 +3000,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2826,10 +3022,10 @@ contains end subroutine psb_z_coo_csput_a -subroutine psb_z_cp_coo_to_coo(a,b,info) +subroutine psb_z_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_coo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2868,10 +3064,10 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) end subroutine psb_z_cp_coo_to_coo -subroutine psb_z_cp_coo_from_coo(a,b,info) +subroutine psb_z_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_coo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2914,10 +3110,10 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) end subroutine psb_z_cp_coo_from_coo -subroutine psb_z_cp_coo_to_fmt(a,b,info) +subroutine psb_z_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_fmt - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -2946,10 +3142,10 @@ subroutine psb_z_cp_coo_to_fmt(a,b,info) end subroutine psb_z_cp_coo_to_fmt -subroutine psb_z_cp_coo_from_fmt(a,b,info) +subroutine psb_z_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_fmt - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -2980,10 +3176,10 @@ subroutine psb_z_cp_coo_from_fmt(a,b,info) end subroutine psb_z_cp_coo_from_fmt -subroutine psb_z_mv_coo_to_coo(a,b,info) +subroutine psb_z_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_to_coo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3022,10 +3218,10 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) end subroutine psb_z_mv_coo_to_coo -subroutine psb_z_mv_coo_from_coo(a,b,info) +subroutine psb_z_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_from_coo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3066,10 +3262,10 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) end subroutine psb_z_mv_coo_from_coo -subroutine psb_z_mv_coo_to_fmt(a,b,info) +subroutine psb_z_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_to_fmt - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3098,10 +3294,10 @@ subroutine psb_z_mv_coo_to_fmt(a,b,info) end subroutine psb_z_mv_coo_to_fmt -subroutine psb_z_mv_coo_from_fmt(a,b,info) +subroutine psb_z_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_mv_coo_from_fmt - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3134,7 +3330,7 @@ end subroutine psb_z_mv_coo_from_fmt subroutine psb_z_coo_cp_from(a,b) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_cp_from - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat), intent(in) :: b @@ -3164,7 +3360,7 @@ end subroutine psb_z_coo_cp_from subroutine psb_z_coo_mv_from(a,b) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_mv_from - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat), intent(inout) :: b @@ -3193,11 +3389,11 @@ end subroutine psb_z_coo_mv_from -subroutine psb_z_fix_coo(a,info,idir) +subroutine psb_z_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3218,17 +3414,17 @@ subroutine psb_z_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_z_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -3251,14 +3447,14 @@ end subroutine psb_z_fix_coo -subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) @@ -3283,14 +3479,14 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -3299,17 +3495,17 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - select case(idir_) - case(psb_row_major_) + select case(idir_) + + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -3319,15 +3515,15 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -3338,9 +3534,9 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -3348,7 +3544,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3358,87 +3554,87 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3450,7 +3646,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -3459,7 +3655,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3469,73 +3665,73 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3544,15 +3740,15 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. - ! + ! let's try in place. + ! call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) @@ -3580,52 +3776,52 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3638,7 +3834,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -3648,13 +3844,13 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -3668,10 +3864,10 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -3679,7 +3875,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -3689,86 +3885,86 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -3780,7 +3976,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -3788,7 +3984,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -3797,73 +3993,73 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -3874,7 +4070,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & @@ -3902,42 +4098,42 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -3945,8 +4141,8 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -3965,7 +4161,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -3979,10 +4175,10 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_z_fix_coo_inner -subroutine psb_z_cp_coo_to_lcoo(a,b,info) +subroutine psb_z_cp_coo_to_lcoo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_lcoo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4022,10 +4218,10 @@ subroutine psb_z_cp_coo_to_lcoo(a,b,info) end subroutine psb_z_cp_coo_to_lcoo -subroutine psb_z_cp_coo_from_lcoo(a,b,info) +subroutine psb_z_cp_coo_from_lcoo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_lcoo - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -4073,11 +4269,11 @@ end subroutine psb_z_cp_coo_from_lcoo ! ! -subroutine psb_lz_coo_get_diag(a,d,info) +subroutine psb_lz_coo_get_diag(a,d,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4092,19 +4288,19 @@ subroutine psb_lz_coo_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = zone + if (a%is_unit()) then + d(1:mnm) = zone else d(1:mnm) = zzero do i=1,a%get_nzeros() j=a%ia(i) - if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then d(j) = a%val(i) endif enddo @@ -4118,12 +4314,12 @@ subroutine psb_lz_coo_get_diag(a,d,info) end subroutine psb_lz_coo_get_diag -subroutine psb_lz_coo_scal(d,a,info,side) +subroutine psb_lz_coo_scal(d,a,info,side) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scal use psb_error_mod use psb_const_mod use psb_string_mod - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4133,44 +4329,44 @@ subroutine psb_lz_coo_scal(d,a,info,side) integer(psb_lpk_) :: mnm, i, j, m character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - - if (left) then + + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ia(i) a%val(i) = a%val(i) * d(j) enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -4188,11 +4384,11 @@ subroutine psb_lz_coo_scal(d,a,info,side) end subroutine psb_lz_coo_scal -subroutine psb_lz_coo_scals(d,a,info) +subroutine psb_lz_coo_scals(d,a,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scals use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4206,7 +4402,7 @@ subroutine psb_lz_coo_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -4228,7 +4424,7 @@ end subroutine psb_lz_coo_scals function psb_lz_coo_maxval(a) result(res) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_maxval - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -4238,13 +4434,13 @@ function psb_lz_coo_maxval(a) result(res) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero end if nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -4254,7 +4450,7 @@ end function psb_lz_coo_maxval function psb_lz_coo_csnmi(a) result(res) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnmi - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -4271,15 +4467,15 @@ function psb_lz_coo_csnmi(a) result(res) res = dzero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_by_rows()) then + if (a%is_by_rows()) then i = 1 j = i - res = dzero - do while (i<=nnz) + res = dzero + do while (i<=nnz) do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) j = j+1 enddo - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -4294,7 +4490,7 @@ function psb_lz_coo_csnmi(a) result(res) m = a%get_nrows() allocate(vt(m),stat=info) if (info /= 0) return - if (is_unit) then + if (is_unit) then vt = done else vt = dzero @@ -4306,7 +4502,7 @@ function psb_lz_coo_csnmi(a) result(res) res = maxval(vt(1:m)) deallocate(vt,stat=info) end if - + end function psb_lz_coo_csnmi @@ -4315,7 +4511,7 @@ function psb_lz_coo_csnm1(a) result(res) use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnm1 - implicit none + implicit none class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -4334,7 +4530,7 @@ function psb_lz_coo_csnm1(a) result(res) n = a%get_ncols() allocate(vt(n),stat=info) if (info /= 0) return - if (a%is_unit()) then + if (a%is_unit()) then vt = done else vt = dzero @@ -4350,7 +4546,7 @@ function psb_lz_coo_csnm1(a) result(res) end function psb_lz_coo_csnm1 -subroutine psb_lz_coo_rowsum(d,a) +subroutine psb_lz_coo_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_rowsum @@ -4371,13 +4567,13 @@ subroutine psb_lz_coo_rowsum(d,a) m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = zone else d = zzero @@ -4391,7 +4587,7 @@ subroutine psb_lz_coo_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4399,7 +4595,7 @@ subroutine psb_lz_coo_rowsum(d,a) end subroutine psb_lz_coo_rowsum -subroutine psb_lz_coo_arwsum(d,a) +subroutine psb_lz_coo_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_arwsum @@ -4419,13 +4615,13 @@ subroutine psb_lz_coo_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -4438,7 +4634,7 @@ subroutine psb_lz_coo_arwsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4446,7 +4642,7 @@ subroutine psb_lz_coo_arwsum(d,a) end subroutine psb_lz_coo_arwsum -subroutine psb_lz_coo_colsum(d,a) +subroutine psb_lz_coo_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_colsum @@ -4466,13 +4662,13 @@ subroutine psb_lz_coo_colsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = zone else d = zzero @@ -4486,7 +4682,7 @@ subroutine psb_lz_coo_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4494,7 +4690,7 @@ subroutine psb_lz_coo_colsum(d,a) end subroutine psb_lz_coo_colsum -subroutine psb_lz_coo_aclsum(d,a) +subroutine psb_lz_coo_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_aclsum @@ -4514,14 +4710,14 @@ subroutine psb_lz_coo_aclsum(d,a) if (a%is_dev()) call a%sync() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -4532,10 +4728,10 @@ subroutine psb_lz_coo_aclsum(d,a) k = a%ja(j) d(k) = d(k) + abs(a%val(j)) end do - + return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -4543,11 +4739,207 @@ subroutine psb_lz_coo_aclsum(d,a) end subroutine psb_lz_coo_aclsum -subroutine psb_lz_coo_reallocate_nz(nz,a) +subroutine psb_lz_coo_scalplusidentity(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scalplusidentity + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act,mnm, i, j, m + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + mnm = min(a%get_nrows(),a%get_ncols()) + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + a%val(i) = a%val(i) + zone + endif + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_scalplusidentity + +subroutine psb_lz_coo_spaxpby(alpha,a,beta,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_spaxpby + use psb_error_mod + use psb_const_mod + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + complex(psb_dpk_), intent(in) :: alpha + complex(psb_dpk_), intent(in) :: beta + integer(psb_ipk_), intent(out) :: info + + !Local + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_spaxpby' + type(psb_lz_coo_sparse_mat) :: tcoo,bcoo + integer(psb_lpk_) :: nza, nzb, M, N + + call psb_erractionsave(err_act) + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = alpha*a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = beta*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + ! Move to correct output format + call tcoo%mv_to_coo(a,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='mv_to_coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lz_coo_spaxpby + +function psb_lz_coo_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cmpval + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza + + nza = a%get_nzeros() + + if (any(abs(a%val(1:nza)-val) > tol)) then + res = .false. + else + res = .true. + end if + + info = psb_success_ + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lz_coo_cmpval + +function psb_lz_coo_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cmpmat + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + integer(psb_ipk_), intent(out) :: info + logical :: res + + ! Auxiliary + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + integer(psb_lpk_) :: nza, nzb, nzl, M, N + type(psb_lz_coo_sparse_mat) :: tcoo, bcoo + + ! Copy (whatever) b format to coo + call b%cp_to_coo(bcoo,info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='cp_to_coo') + goto 9999 + end if + ! Get information on the matrix + M = a%get_nrows() + N = a%get_ncols() + nza = a%get_nzeros() + nzb = b%get_nzeros() + ! Allocate (temporary) space for the solution + call tcoo%allocate(M,N,(nza+nzb)) + ! Compute the sum + tcoo%ia(1:nza) = a%ia(1:nza) + tcoo%ja(1:nza) = a%ja(1:nza) + tcoo%val(1:nza) = a%val(1:nza) + tcoo%ia(nza+1:nza+nzb) = bcoo%ia(1:nzb) + tcoo%ja(nza+1:nza+nzb) = bcoo%ja(1:nzb) + tcoo%val(nza+1:nza+nzb) = (-1_psb_dpk_)*bcoo%val(1:nzb) + ! Fix the indexes + call tcoo%fix(info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='fix') + goto 9999 + end if + nzl = tcoo%get_nzeros() + + if (any(abs(tcoo%val(1:nzl)) > tol)) then + res = .false. + else + res = .true. + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end function psb_lz_coo_cmpmat + +subroutine psb_lz_coo_reallocate_nz(nz,a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reallocate_nz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4562,7 +4954,7 @@ subroutine psb_lz_coo_reallocate_nz(nz,a) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4576,11 +4968,11 @@ subroutine psb_lz_coo_reallocate_nz(nz,a) end subroutine psb_lz_coo_reallocate_nz -subroutine psb_lz_coo_ensure_size(nz,a) +subroutine psb_lz_coo_ensure_size(nz,a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_ensure_size use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz_ @@ -4594,7 +4986,7 @@ subroutine psb_lz_coo_ensure_size(nz,a) if (info == psb_success_) call psb_ensure_size(nz_,a%ja,info) if (info == psb_success_) call psb_ensure_size(nz_,a%val,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4608,10 +5000,10 @@ subroutine psb_lz_coo_ensure_size(nz,a) end subroutine psb_lz_coo_ensure_size -subroutine psb_lz_coo_mold(a,b,info) +subroutine psb_lz_coo_mold(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mold use psb_error_mod - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4620,16 +5012,16 @@ subroutine psb_lz_coo_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_lz_coo_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4644,9 +5036,9 @@ end subroutine psb_lz_coo_mold subroutine psb_lz_coo_reinit(a,clear) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reinit use psb_error_mod - implicit none + implicit none - class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4658,17 +5050,17 @@ subroutine psb_lz_coo_reinit(a,clear) info = psb_success_ - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if if (a%is_dev()) call a%sync() - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = zzero call a%set_host() call a%set_upd() @@ -4693,7 +5085,7 @@ subroutine psb_lz_coo_trim(a) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_trim use psb_realloc_mod use psb_error_mod - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info integer(psb_lpk_) :: nz @@ -4708,7 +5100,7 @@ subroutine psb_lz_coo_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4721,13 +5113,13 @@ end subroutine psb_lz_coo_trim subroutine psb_lz_coo_clean_zeros(a, info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_zeros - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i,j,k, nzin - info = 0 + info = 0 nzin = a%get_nzeros() j = 0 do i=1, nzin @@ -4738,14 +5130,14 @@ subroutine psb_lz_coo_clean_zeros(a, info) a%ja(j) = a%ja(i) end if end do - call a%set_nzeros(j) + call a%set_nzeros(j) call a%trim() end subroutine psb_lz_coo_clean_zeros subroutine psb_lz_coo_clean_negidx(a,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_negidx - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info ! @@ -4753,14 +5145,14 @@ subroutine psb_lz_coo_clean_negidx(a,info) integer(psb_lpk_) :: nz call psb_coo_clean_negidx_inner(a%get_nzeros(),a%ia,a%ja,a%val,nz,info) if (info == 0) call a%set_nzeros(nz) - + end subroutine psb_lz_coo_clean_negidx -#if defined(IPK4) && defined(LPK8) -subroutine psb_lz_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) +#if defined(IPK4) && defined(LPK8) +subroutine psb_lz_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_negidx_inner - implicit none + implicit none integer(psb_lpk_), intent(in) :: nzin integer(psb_lpk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) @@ -4769,25 +5161,25 @@ subroutine psb_lz_coo_clean_negidx_inner(nzin,ia,ja,val,nzout,info) ! ! integer(psb_lpk_) :: i - info = 0 - nzout = 0 + info = 0 + nzout = 0 do i=1, nzin if ((ia(i)>0).and.(ja(i)>0)) then - nzout = nzout + 1 + nzout = nzout + 1 val(nzout) = val(i) ia(nzout) = ia(i) ja(nzout) = ja(i) end if end do - + end subroutine psb_lz_coo_clean_negidx_inner #endif -subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) +subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_allocate_mnnz use psb_error_mod use psb_realloc_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4798,22 +5190,22 @@ subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 @@ -4821,7 +5213,7 @@ subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then call a%set_nrows(m) call a%set_ncols(n) call a%set_nzeros(lzero) @@ -4833,7 +5225,7 @@ subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) call a%set_sorted(.true.) call a%set_host() end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4848,10 +5240,10 @@ end subroutine psb_lz_coo_allocate_mnnz subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_print use psb_string_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4864,8 +5256,8 @@ subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) integer(psb_lpk_) :: i,j, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4874,26 +5266,26 @@ subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_lz_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do j=1,a%get_nzeros() write(iout,frmt) iv(a%ia(j)),iv(a%ja(j)),a%val(j) enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),a%ja(j),a%val(j) enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),ivc(a%ja(j)),a%val(j) enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do j=1,a%get_nzeros() write(iout,frmt) a%ia(j),a%ja(j),a%val(j) enddo @@ -4908,7 +5300,7 @@ end subroutine psb_lz_coo_print function psb_lz_coo_get_nz_row(idx,a) result(res) use psb_const_mod use psb_sort_mod - use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_nz_row + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_nz_row implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a @@ -4918,40 +5310,40 @@ function psb_lz_coo_get_nz_row(idx,a) result(res) integer(psb_ipk_) :: inza if (a%is_dev()) call a%sync() - res = 0 + res = 0 nza = a%get_nzeros() - if (a%is_by_rows()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. inza = nza ip = psb_bsrch(idx,inza,a%ia) if (ip /= -1) return - jp = ip - do + jp = ip + do if (ip < 2) exit - if (a%ia(ip-1) == idx) then - ip = ip -1 - else + if (a%ia(ip-1) == idx) then + ip = ip -1 + else exit end if end do - do + do if (jp == nza) exit - if (a%ia(jp+1) == idx) then + if (a%ia(jp+1) == idx) then jp = jp + 1 - else + else exit end if end do - res = jp - ip +1 + res = jp - ip +1 else res = 0 do i=1, nza - if (a%ia(i) == idx) then - res = res + 1 + if (a%ia(i) == idx) then + res = res + 1 end if end do @@ -4975,7 +5367,7 @@ end function psb_lz_coo_get_nz_row subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4992,7 +5384,7 @@ subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5021,22 +5413,22 @@ subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5045,12 +5437,12 @@ subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& call coo_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5095,19 +5487,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5122,13 +5514,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5146,31 +5538,31 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(a%ia(i)) @@ -5179,7 +5571,7 @@ contains enddo else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = a%ia(i) @@ -5187,8 +5579,8 @@ contains end if enddo end if - else - nz = 0 + else + nz = 0 end if else @@ -5201,12 +5593,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5218,11 +5610,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5236,7 +5628,7 @@ contains enddo nzin_=nzin_+k end if - nz = k + nz = k end if end subroutine coo_getptn @@ -5245,12 +5637,12 @@ end subroutine psb_lz_coo_csgetptn ! -! NZ is the number of non-zeros on output. +! NZ is the number of non-zeros on output. ! The output is guaranteed to be sorted -! +! subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -5268,7 +5660,7 @@ subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -5296,22 +5688,22 @@ subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -5320,12 +5712,12 @@ subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call coo_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - if (rscale_) then + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -5374,19 +5766,19 @@ contains inza = nza irw = imin lrw = imax - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif - if (a%is_by_rows()) then - ! In this case we can do a binary search. + if (a%is_by_rows()) then + ! In this case we can do a binary search. if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do @@ -5401,13 +5793,13 @@ contains end if end do - if (ip /= -1) then + if (ip /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (ip < 2) exit - if (a%ia(ip-1) == irw) then - ip = ip -1 - else + if (a%ia(ip-1) == irw) then + ip = ip -1 + else exit end if end do @@ -5425,32 +5817,32 @@ contains end if end do - if (jp /= -1) then + if (jp /= -1) then ! expand [ip,jp] to contain all row entries. - do + do if (jp == nza) exit - if (a%ia(jp+1) == lrw) then + if (a%ia(jp+1) == lrw) then jp = jp + 1 - else + else exit end if end do end if if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then + if ((ip /= -1) .and.(jp /= -1)) then ! Now do the copy. - nzt = jp - ip +1 - nz = 0 + nzt = jp - ip +1 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then + if (present(iren)) then do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = iren(a%ia(i)) @@ -5458,10 +5850,10 @@ contains end if enddo call psb_lz_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) - nz = nz - nzin_ + nz = nz - nzin_ else do i=ip,jp - if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then nz = nz + 1 val(nzin_+nz) = a%val(i) ia(nzin_+nz) = a%ia(i) @@ -5470,7 +5862,7 @@ contains enddo end if else - nz = 0 + nz = 0 end if else @@ -5484,12 +5876,12 @@ contains if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - if (present(iren)) then - k = 0 + if (present(iren)) then + k = 0 do i=1, a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5503,11 +5895,11 @@ contains endif enddo else - k = 0 + k = 0 do i=1,a%get_nzeros() if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& - & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then - k = k + 1 + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 if (k > nzt) then nzt = k + nzt call psb_ensure_size(nzin_+nzt,ia,info) @@ -5531,12 +5923,12 @@ contains end subroutine psb_lz_coo_csgetrow -subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_sort_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csput_a - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -5549,30 +5941,30 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) logical, parameter :: debug=.false. integer(psb_lpk_) :: nza, i,j,k, nzl, isza integer(psb_ipk_) :: debug_level, debug_unit - + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (nz < 0) then + if (nz < 0) then info = psb_err_iarg_neg_ call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 @@ -5583,13 +5975,13 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() isza = a%get_size() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then call a%reallocate(max(nza+nz,int(1.5*isza))) endif isza = a%get_size() - if (isza < (nza+nz)) then + if (isza < (nza+nz)) then info = psb_err_alloc_dealloc_; call psb_errpush(info,name) goto 9999 end if @@ -5600,22 +5992,22 @@ subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) call a%set_sorted(.false.) - else if (a%is_upd()) then + else if (a%is_upd()) then if (a%is_dev()) call a%sync() call lz_coo_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -5636,7 +6028,7 @@ contains subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& & imin,imax,jmin,jmax,info) - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz integer(psb_lpk_), intent(in) :: ia(:),ja(:) @@ -5647,11 +6039,11 @@ contains integer(psb_lpk_) :: i,ir,ic info = psb_success_ - do i=1, nz + do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 ia1(nza) = ir ia2(nza) = ic aspk(nza) = val(i) @@ -5667,7 +6059,7 @@ contains use psb_const_mod use psb_realloc_mod use psb_string_mod - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -5685,13 +6077,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() innz = nnz @@ -5702,18 +6094,18 @@ contains ! Cannot test for error, should have been caught earlier. do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5725,7 +6117,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -5739,18 +6131,18 @@ contains ! Add do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then - if (ir /= ilr) then + if (ir /= ilr) then i1 = psb_bsrch(ir,innz,a%ia) i2 = i1 - do + do if (i2+1 > nnz) exit if (a%ia(i2+1) /= a%ia(i2)) exit i2 = i2 + 1 end do - do + do if (i1-1 < 1) exit if (a%ia(i1-1) /= a%ia(i1)) exit i1 = i1 - 1 @@ -5762,7 +6154,7 @@ contains end if nc = i2-i1+1 ip = psb_ssrch(ic,nc,a%ja(i1:i2)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -5784,10 +6176,10 @@ contains end subroutine psb_lz_coo_csput_a -subroutine psb_lz_cp_coo_to_coo(a,b,info) +subroutine psb_lz_cp_coo_to_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_coo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5827,10 +6219,10 @@ subroutine psb_lz_cp_coo_to_coo(a,b,info) end subroutine psb_lz_cp_coo_to_coo -subroutine psb_lz_cp_coo_from_coo(a,b,info) +subroutine psb_lz_cp_coo_from_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_coo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5873,10 +6265,10 @@ subroutine psb_lz_cp_coo_from_coo(a,b,info) end subroutine psb_lz_cp_coo_from_coo -subroutine psb_lz_cp_coo_to_fmt(a,b,info) +subroutine psb_lz_cp_coo_to_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_fmt - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5905,10 +6297,10 @@ subroutine psb_lz_cp_coo_to_fmt(a,b,info) end subroutine psb_lz_cp_coo_to_fmt -subroutine psb_lz_cp_coo_from_fmt(a,b,info) +subroutine psb_lz_cp_coo_from_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_fmt - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -5939,10 +6331,10 @@ subroutine psb_lz_cp_coo_from_fmt(a,b,info) end subroutine psb_lz_cp_coo_from_fmt -subroutine psb_lz_mv_coo_to_coo(a,b,info) +subroutine psb_lz_mv_coo_to_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_coo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -5981,10 +6373,10 @@ subroutine psb_lz_mv_coo_to_coo(a,b,info) end subroutine psb_lz_mv_coo_to_coo -subroutine psb_lz_mv_coo_from_coo(a,b,info) +subroutine psb_lz_mv_coo_from_coo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_coo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6025,10 +6417,10 @@ subroutine psb_lz_mv_coo_from_coo(a,b,info) end subroutine psb_lz_mv_coo_from_coo -subroutine psb_lz_mv_coo_to_fmt(a,b,info) +subroutine psb_lz_mv_coo_to_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_fmt - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6057,10 +6449,10 @@ subroutine psb_lz_mv_coo_to_fmt(a,b,info) end subroutine psb_lz_mv_coo_to_fmt -subroutine psb_lz_mv_coo_from_fmt(a,b,info) +subroutine psb_lz_mv_coo_from_fmt(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_fmt - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6093,7 +6485,7 @@ end subroutine psb_lz_mv_coo_from_fmt subroutine psb_lz_coo_cp_from(a,b) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cp_from - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a type(psb_lz_coo_sparse_mat), intent(in) :: b @@ -6123,7 +6515,7 @@ end subroutine psb_lz_coo_cp_from subroutine psb_lz_coo_mv_from(a,b) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mv_from - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a type(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -6152,11 +6544,11 @@ end subroutine psb_lz_coo_mv_from -subroutine psb_lz_fix_coo(a,info,idir) +subroutine psb_lz_fix_coo(a,info,idir) use psb_const_mod use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -6177,17 +6569,17 @@ subroutine psb_lz_fix_coo(a,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(a%ia),size(a%ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif if (a%is_dev()) call a%sync() - + nra = a%get_nrows() nca = a%get_ncols() nza = a%get_nzeros() - if (nza >= 2) then + if (nza >= 2) then dupl_ = a%get_dupl() call psb_lz_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) if (info /= psb_success_) goto 9999 @@ -6210,14 +6602,14 @@ end subroutine psb_lz_fix_coo -subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) +subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_const_mod use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo_inner use psb_string_mod use psb_ip_reord_mod use psb_sort_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl integer(psb_lpk_), intent(inout) :: ia(:), ja(:) @@ -6244,14 +6636,14 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if(debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),': start ',& & size(ia),size(ja) - if (present(idir)) then + if (present(idir)) then idir_ = idir else idir_ = psb_row_major_ endif - if (nzin < 2) then + if (nzin < 2) then call psb_erractionrestore(err_act) return end if @@ -6260,16 +6652,16 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - allocate(iaux(nzin+2),stat=info) - if (info /= psb_success_) then + allocate(iaux(nzin+2),stat=info) + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - select case(idir_) + select case(idir_) - case(psb_row_major_) + case(psb_row_major_) ! Row major order if (nr <= nzin) then ! Avoid strange situations with large indices @@ -6277,17 +6669,17 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = (info == 0) else use_buffers = .false. - end if - - if (use_buffers) then - if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + end if + + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then iaux(:) = 0 iaux(ia(1)) = iaux(ia(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ia(i) < 1).or.(ia(i)> nr)) then + if ( (ia(i) < 1).or.(ia(i)> nr)) then use_buffers = .false. - srt_inp = .false. + srt_inp = .false. exit end if iaux(ia(i)) = iaux(ia(i)) + 1 @@ -6298,9 +6690,9 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if end if ! Check again use_buffers. - if (use_buffers) then - if (srt_inp) then - ! If input was already row-major + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major ! we can do it row-by-row here. k = 0 i = 1 @@ -6308,7 +6700,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6318,87 +6710,87 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already row-major + else if (.not.srt_inp) then + ! If input was not already row-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nr - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6410,7 +6802,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(irw) = ip + iaux(irw) = ip end do k = 0 i = 1 @@ -6419,7 +6811,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6429,73 +6821,73 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6504,14 +6896,14 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if i=k - + deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then ! ! If we did not have enough memory for buffers, - ! let's try in place. + ! let's try in place. ! inzin = nzin call psi_msort_up(inzin,ia(1:),iaux(1:),iret) @@ -6541,52 +6933,52 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6599,7 +6991,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) & write(debug_unit,*) trim(name),': end second loop' - case(psb_col_major_) + case(psb_col_major_) if (nc <= nzin) then ! Avoid strange situations with large indices @@ -6609,13 +7001,13 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use_buffers = .false. end if - if (use_buffers) then + if (use_buffers) then iaux(:) = 0 - if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then iaux(ja(1)) = iaux(ja(1)) + 1 - srt_inp = .true. + srt_inp = .true. do i=2,nzin - if ( (ja(i) < 1).or.(ja(i)> nc)) then + if ( (ja(i) < 1).or.(ja(i)> nc)) then use_buffers = .false. srt_inp = .false. exit @@ -6629,10 +7021,10 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end if !use_buffers=use_buffers.and.srt_inp ! Check again use_buffers. - if (use_buffers) then + if (use_buffers) then - if (srt_inp) then - ! If input was already col-major + if (srt_inp) then + ! If input was already col-major ! we can do it col-by-col here. k = 0 i = 1 @@ -6640,7 +7032,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j) imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& @@ -6650,86 +7042,86 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then + if ((ia(i) == irw).and.(ja(i) == icl)) then val(k) = val(k) + val(i) else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ia(i) - ja(k) = ja(i) - val(k) = val(i) - irw = ia(k) - icl = ja(k) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ia(i) == irw).and.(ja(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = val(i) ia(k) = ia(i) ja(k) = ja(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif !i = i + nzl enddo - else if (.not.srt_inp) then - ! If input was not already col-major + else if (.not.srt_inp) then + ! If input was not already col-major ! we have to sort all ip = iaux(1) iaux(1) = 0 do i=2, nc - is = iaux(i) + is = iaux(i) iaux(i) = ip ip = ip + is end do @@ -6741,7 +7133,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ias(ip) = ia(i) jas(ip) = ja(i) vs(ip) = val(i) - iaux(icl) = ip + iaux(icl) = ip end do k = 0 i = 1 @@ -6749,7 +7141,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) nzl = iaux(j)-i+1 imx = i+nzl-1 - if (nzl > 0) then + if (nzl > 0) then call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& @@ -6758,73 +7150,73 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) case(psb_dupl_ovwrt_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_add_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then + if ((ias(i) == irw).and.(jas(i) == icl)) then val(k) = val(k) + vs(i) else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case(psb_dupl_err_) k = k + 1 ia(k) = ias(i) - ja(k) = jas(i) - val(k) = vs(i) - irw = ia(k) - icl = ja(k) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) do i = i + 1 if (i > imx) exit - if ((ias(i) == irw).and.(jas(i) == icl)) then - call psb_errpush(psb_err_duplicate_coo,name) + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else k = k+1 val(k) = vs(i) ia(k) = ias(i) ja(k) = jas(i) - irw = ia(k) - icl = ja(k) + irw = ia(k) + icl = ja(k) endif enddo case default write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ info =-7 - return + return end select endif @@ -6835,7 +7227,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) i=k deallocate(ias,jas,vs,ix2, stat=info) - else if (.not.use_buffers) then + else if (.not.use_buffers) then inzin = nzin call psi_msort_up(inzin,ja(1:),iaux(1:),iret) @@ -6864,42 +7256,42 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) select case(dupl_) case(psb_dupl_ovwrt_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_add_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then val(i) = val(i) + val(j) else i = i+1 val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case(psb_dupl_err_) - do + do j = j + 1 if (j > nzin) exit - if ((ia(j) == irw).and.(ja(j) == icl)) then + if ((ia(j) == irw).and.(ja(j) == icl)) then call psb_errpush(psb_err_duplicate_coo,name) goto 9999 else @@ -6907,8 +7299,8 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) val(i) = val(j) ia(i) = ia(j) ja(i) = ja(j) - irw = ia(i) - icl = ja(i) + irw = ia(i) + icl = ja(i) endif enddo case default @@ -6927,7 +7319,7 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) goto 9999 end select - nzout = i + nzout = i deallocate(iaux) @@ -6941,10 +7333,10 @@ subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_lz_fix_coo_inner -subroutine psb_lz_cp_coo_to_icoo(a,b,info) +subroutine psb_lz_cp_coo_to_icoo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_icoo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -6984,10 +7376,10 @@ subroutine psb_lz_cp_coo_to_icoo(a,b,info) end subroutine psb_lz_cp_coo_to_icoo -subroutine psb_lz_cp_coo_from_icoo(a,b,info) +subroutine psb_lz_cp_coo_from_icoo(a,b,info) use psb_error_mod use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_icoo - implicit none + implicit none class(psb_lz_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -7027,4 +7419,3 @@ subroutine psb_lz_cp_coo_from_icoo(a,b,info) return end subroutine psb_lz_cp_coo_from_icoo - diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index d4c242df9..e1c003d0f 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csmv - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -72,7 +72,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -81,7 +81,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) if (a%is_dev()) call a%sync() - if (size(x,1) psb_z_csc_csmm - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -350,13 +350,13 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) end if tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (tra) then + if (tra) then m = a%get_ncols() n = a%get_nrows() else @@ -364,16 +364,16 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_z_csc_cssv - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -632,7 +632,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -642,28 +642,28 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x,1) psb_z_csc_cssm - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -852,7 +852,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -862,23 +862,23 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C') m = a%get_nrows() - if (size(x,1) psb_z_csc_maxval - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1066,7 +1066,7 @@ function psb_z_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero @@ -1074,7 +1074,7 @@ function psb_z_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1085,7 +1085,7 @@ function psb_z_csc_csnm1(a) result(res) use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csnm1 - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1099,13 +1099,13 @@ function psb_z_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = dzero + res = dzero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -1115,12 +1115,12 @@ function psb_z_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_z_csc_csnm1 -subroutine psb_z_csc_colsum(d,a) +subroutine psb_z_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_colsum @@ -1140,7 +1140,7 @@ subroutine psb_z_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1148,19 +1148,19 @@ subroutine psb_z_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = zone else d(i) = zzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1168,7 +1168,7 @@ subroutine psb_z_csc_colsum(d,a) end subroutine psb_z_csc_colsum -subroutine psb_z_csc_aclsum(d,a) +subroutine psb_z_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_aclsum @@ -1188,7 +1188,7 @@ subroutine psb_z_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1197,25 +1197,25 @@ subroutine psb_z_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = done else d(i) = dzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1223,7 +1223,7 @@ subroutine psb_z_csc_aclsum(d,a) end subroutine psb_z_csc_aclsum -subroutine psb_z_csc_rowsum(d,a) +subroutine psb_z_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_rowsum @@ -1244,14 +1244,14 @@ subroutine psb_z_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = zone else d = zzero @@ -1265,7 +1265,7 @@ subroutine psb_z_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1273,7 +1273,7 @@ subroutine psb_z_csc_rowsum(d,a) end subroutine psb_z_csc_rowsum -subroutine psb_z_csc_arwsum(d,a) +subroutine psb_z_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_arwsum @@ -1294,14 +1294,14 @@ subroutine psb_z_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -1315,7 +1315,7 @@ subroutine psb_z_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1324,11 +1324,11 @@ subroutine psb_z_csc_arwsum(d,a) end subroutine psb_z_csc_arwsum -subroutine psb_z_csc_get_diag(a,d,info) +subroutine psb_z_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_get_diag - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1343,28 +1343,28 @@ subroutine psb_z_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = zone + if (a%is_unit()) then + d(1:mnm) = zone else do i=1, mnm d(i) = zzero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = zzero end do call psb_erractionrestore(err_act) @@ -1377,12 +1377,12 @@ subroutine psb_z_csc_get_diag(a,d,info) end subroutine psb_z_csc_get_diag -subroutine psb_z_csc_scal(d,a,info,side) +subroutine psb_z_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scal use psb_string_mod - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1393,7 +1393,7 @@ subroutine psb_z_csc_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -1401,39 +1401,39 @@ subroutine psb_z_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -1449,11 +1449,11 @@ subroutine psb_z_csc_scal(d,a,info,side) end subroutine psb_z_csc_scal -subroutine psb_z_csc_scals(d,a,info) +subroutine psb_z_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_scals - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1467,7 +1467,7 @@ subroutine psb_z_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1486,7 +1486,7 @@ subroutine psb_z_csc_scals(d,a,info) end subroutine psb_z_csc_scals -! == =================================== +! == =================================== ! ! ! @@ -1496,11 +1496,11 @@ end subroutine psb_z_csc_scals ! ! ! -! == =================================== +! == =================================== subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1518,7 +1518,7 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1547,35 +1547,35 @@ subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1621,12 +1621,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1637,19 +1637,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1663,9 +1663,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -1677,9 +1677,9 @@ contains enddo end do end if - + end subroutine csc_getptn - + end subroutine psb_z_csc_csgetptn @@ -1687,7 +1687,7 @@ end subroutine psb_z_csc_csgetptn subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1706,7 +1706,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' @@ -1716,7 +1716,7 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -1736,22 +1736,22 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -1759,13 +1759,13 @@ subroutine psb_z_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1813,12 +1813,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -1829,7 +1829,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -1837,12 +1837,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1858,9 +1858,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -1880,11 +1880,11 @@ end subroutine psb_z_csc_csgetrow -subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput_a - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -1903,26 +1903,26 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -1933,25 +1933,25 @@ subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_z_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -1977,7 +1977,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -1995,13 +1995,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -2011,19 +2011,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2036,18 +2036,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2070,12 +2070,12 @@ end subroutine psb_z_csc_csput_a -subroutine psb_z_cp_csc_from_coo(a,b,info) +subroutine psb_z_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_from_coo - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b @@ -2098,11 +2098,11 @@ end subroutine psb_z_cp_csc_from_coo -subroutine psb_z_cp_csc_to_coo(a,b,info) +subroutine psb_z_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_to_coo - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b @@ -2132,7 +2132,7 @@ subroutine psb_z_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -2140,12 +2140,12 @@ subroutine psb_z_cp_csc_to_coo(a,b,info) end subroutine psb_z_cp_csc_to_coo -subroutine psb_z_mv_csc_to_coo(a,b,info) +subroutine psb_z_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_to_coo - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b @@ -2183,13 +2183,13 @@ end subroutine psb_z_mv_csc_to_coo -subroutine psb_z_mv_csc_from_coo(a,b,info) +subroutine psb_z_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_coo - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b @@ -2213,7 +2213,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -2236,17 +2236,17 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_z_mv_csc_from_coo -subroutine psb_z_mv_csc_to_fmt(a,b,info) +subroutine psb_z_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_to_fmt - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b @@ -2262,10 +2262,10 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_z_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_z_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -2282,12 +2282,12 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info) end subroutine psb_z_mv_csc_to_fmt !!$ -subroutine psb_z_cp_csc_to_fmt(a,b,info) +subroutine psb_z_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_to_fmt - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b @@ -2303,10 +2303,10 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_z_csc_sparse_mat) + type is (psb_z_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat nc = a%get_ncols() @@ -2324,12 +2324,12 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info) end subroutine psb_z_cp_csc_to_fmt -subroutine psb_z_mv_csc_from_fmt(a,b,info) +subroutine psb_z_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_mv_csc_from_fmt - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b @@ -2345,10 +2345,10 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_z_csc_sparse_mat) + type is (psb_z_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat @@ -2369,19 +2369,19 @@ end subroutine psb_z_mv_csc_from_fmt subroutine psb_z_csc_clean_zeros(a, info) use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_clean_zeros - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nc - integer(psb_ipk_), allocatable :: ilcp(:) - + integer(psb_ipk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= zzero) then @@ -2396,12 +2396,12 @@ subroutine psb_z_csc_clean_zeros(a, info) call a%set_host() end subroutine psb_z_csc_clean_zeros -subroutine psb_z_cp_csc_from_fmt(a,b,info) +subroutine psb_z_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_cp_csc_from_fmt - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b @@ -2417,10 +2417,10 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_z_csc_sparse_mat) + type is (psb_z_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat nc = b%get_ncols() @@ -2435,14 +2435,14 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_z_cp_csc_from_fmt -subroutine psb_z_csc_mold(a,b,info) +subroutine psb_z_csc_mold(a,b,info) use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mold use psb_error_mod - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -2452,16 +2452,16 @@ subroutine psb_z_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_z_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -2473,11 +2473,11 @@ subroutine psb_z_csc_mold(a,b,info) end subroutine psb_z_csc_mold -subroutine psb_z_csc_reallocate_nz(nz,a) +subroutine psb_z_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -2490,7 +2490,7 @@ subroutine psb_z_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -2508,7 +2508,7 @@ end subroutine psb_z_csc_reallocate_nz !!$subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& !!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ ! Output is always in COO format +!!$ ! Output is always in COO format !!$ use psb_error_mod !!$ use psb_const_mod !!$ use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csgetblk @@ -2531,12 +2531,12 @@ end subroutine psb_z_csc_reallocate_nz !!$ call psb_erractionsave(err_act) !!$ info = psb_success_ !!$ -!!$ if (present(append)) then +!!$ if (present(append)) then !!$ append_ = append !!$ else !!$ append_ = .false. !!$ endif -!!$ if (append_) then +!!$ if (append_) then !!$ nzin = a%get_nzeros() !!$ else !!$ nzin = 0 @@ -2564,9 +2564,9 @@ end subroutine psb_z_csc_reallocate_nz subroutine psb_z_csc_reinit(a,clear) use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_reinit - implicit none + implicit none - class(psb_z_csc_sparse_mat), intent(inout) :: a + class(psb_z_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2580,16 +2580,16 @@ subroutine psb_z_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = zzero call a%set_upd() call a%set_host() @@ -2612,7 +2612,7 @@ subroutine psb_z_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_trim - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, n integer(psb_ipk_) :: ierr(5) @@ -2627,7 +2627,7 @@ subroutine psb_z_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2637,11 +2637,11 @@ subroutine psb_z_csc_trim(a) end subroutine psb_z_csc_trim -subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -2652,26 +2652,26 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -2679,7 +2679,7 @@ subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -2702,25 +2702,27 @@ end subroutine psb_z_csc_allocate_mnnz subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_csc_print' logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='complex' character(len=80) :: frmt - integer(psb_ipk_) :: i,j, ni, nr, nc, nz + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + - write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2729,35 +2731,35 @@ subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_z_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -2770,7 +2772,7 @@ subroutine psb_zcscspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_zcscspspmm - implicit none + implicit none class(psb_z_csc_sparse_mat), intent(in) :: a,b type(psb_z_csc_sparse_mat), intent(out) :: c @@ -2790,7 +2792,7 @@ subroutine psb_zcscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -2819,9 +2821,9 @@ subroutine psb_zcscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_z_csc_sparse_mat), intent(in) :: a,b type(psb_z_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -2844,29 +2846,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -2874,11 +2876,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do @@ -2891,11 +2893,11 @@ end subroutine psb_zcscspspmm -subroutine psb_lz_csc_get_diag(a,d,info) +subroutine psb_lz_csc_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_get_diag - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2910,28 +2912,28 @@ subroutine psb_lz_csc_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then - d(1:mnm) = zone + if (a%is_unit()) then + d(1:mnm) = zone else do i=1, mnm d(i) = zzero do k=a%icp(i),a%icp(i+1)-1 j=a%ia(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do endif - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = zzero end do call psb_erractionrestore(err_act) @@ -2944,12 +2946,12 @@ subroutine psb_lz_csc_get_diag(a,d,info) end subroutine psb_lz_csc_get_diag -subroutine psb_lz_csc_scal(d,a,info,side) +subroutine psb_lz_csc_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_scal use psb_string_mod - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2960,7 +2962,7 @@ subroutine psb_lz_csc_scal(d,a,info,side) integer(psb_ipk_) :: err_act,ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ @@ -2968,39 +2970,39 @@ subroutine psb_lz_csc_scal(d,a,info,side) if (a%is_dev()) call a%sync() side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if left = (side_ == 'L') - - if (left) then + + if (left) then n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1, a%get_nzeros() a%val(i) = a%val(i) * d(a%ia(i)) enddo else n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if do j=1, n - do i = a%icp(j), a%icp(j+1) -1 + do i = a%icp(j), a%icp(j+1) -1 a%val(i) = a%val(i) * d(j) end do enddo @@ -3016,11 +3018,11 @@ subroutine psb_lz_csc_scal(d,a,info,side) end subroutine psb_lz_csc_scal -subroutine psb_lz_csc_scals(d,a,info) +subroutine psb_lz_csc_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_scals - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3034,7 +3036,7 @@ subroutine psb_lz_csc_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3056,7 +3058,7 @@ end subroutine psb_lz_csc_scals function psb_lz_csc_maxval(a) result(res) use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_maxval - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3065,7 +3067,7 @@ function psb_lz_csc_maxval(a) result(res) logical, parameter :: debug=.false. - if (a%is_unit()) then + if (a%is_unit()) then res = done else res = dzero @@ -3073,7 +3075,7 @@ function psb_lz_csc_maxval(a) result(res) if (a%is_dev()) call a%sync() nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3084,7 +3086,7 @@ function psb_lz_csc_csnm1(a) result(res) use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csnm1 - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3097,13 +3099,13 @@ function psb_lz_csc_csnm1(a) result(res) logical, parameter :: debug=.false. - res = dzero + res = dzero if (a%is_dev()) call a%sync() m = a%get_nrows() n = a%get_ncols() is_unit = a%is_unit() do j=1, n - if (is_unit) then + if (is_unit) then acc = done else acc = dzero @@ -3113,12 +3115,12 @@ function psb_lz_csc_csnm1(a) result(res) end do res = max(res,acc) end do - + return end function psb_lz_csc_csnm1 -subroutine psb_lz_csc_colsum(d,a) +subroutine psb_lz_csc_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_colsum @@ -3139,7 +3141,7 @@ subroutine psb_lz_csc_colsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3147,19 +3149,19 @@ subroutine psb_lz_csc_colsum(d,a) end if is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = zone else d(i) = zzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - + call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3167,7 +3169,7 @@ subroutine psb_lz_csc_colsum(d,a) end subroutine psb_lz_csc_colsum -subroutine psb_lz_csc_aclsum(d,a) +subroutine psb_lz_csc_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_aclsum @@ -3188,7 +3190,7 @@ subroutine psb_lz_csc_aclsum(d,a) if (a%is_dev()) call a%sync() m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3197,25 +3199,25 @@ subroutine psb_lz_csc_aclsum(d,a) is_unit = a%is_unit() do i = 1, a%get_ncols() - if (is_unit) then + if (is_unit) then d(i) = done else d(i) = dzero end if - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, a%get_ncols() d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3223,7 +3225,7 @@ subroutine psb_lz_csc_aclsum(d,a) end subroutine psb_lz_csc_aclsum -subroutine psb_lz_csc_rowsum(d,a) +subroutine psb_lz_csc_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_rowsum @@ -3231,7 +3233,7 @@ subroutine psb_lz_csc_rowsum(d,a) complex(psb_dpk_), intent(out) :: d(:) integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc - integer(psb_epk_) :: m,n + integer(psb_epk_) :: m,n complex(psb_dpk_) :: acc complex(psb_dpk_), allocatable :: vt(:) logical :: tra @@ -3245,14 +3247,14 @@ subroutine psb_lz_csc_rowsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = zone else d = zzero @@ -3266,7 +3268,7 @@ subroutine psb_lz_csc_rowsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3274,7 +3276,7 @@ subroutine psb_lz_csc_rowsum(d,a) end subroutine psb_lz_csc_rowsum -subroutine psb_lz_csc_arwsum(d,a) +subroutine psb_lz_csc_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_arwsum @@ -3296,14 +3298,14 @@ subroutine psb_lz_csc_arwsum(d,a) m = a%get_ncols() n = a%get_nrows() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d = done else d = dzero @@ -3317,7 +3319,7 @@ subroutine psb_lz_csc_arwsum(d,a) end do call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3326,7 +3328,7 @@ subroutine psb_lz_csc_arwsum(d,a) end subroutine psb_lz_csc_arwsum -! == =================================== +! == =================================== ! ! ! @@ -3336,11 +3338,11 @@ end subroutine psb_lz_csc_arwsum ! ! ! -! == =================================== +! == =================================== subroutine psb_lz_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3358,7 +3360,7 @@ subroutine psb_lz_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3387,35 +3389,35 @@ subroutine psb_lz_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call lcsc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3461,12 +3463,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3477,19 +3479,19 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return isz = min(size(ia),size(ja)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3503,9 +3505,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) isz = min(size(ia),size(ja)) @@ -3517,9 +3519,9 @@ contains enddo end do end if - + end subroutine lcsc_getptn - + end subroutine psb_lz_csc_csgetptn @@ -3527,7 +3529,7 @@ end subroutine psb_lz_csc_csgetptn subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3546,7 +3548,7 @@ subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='csget' @@ -3556,7 +3558,7 @@ subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -3576,22 +3578,22 @@ subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -3599,13 +3601,13 @@ subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call lcsc_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -3653,12 +3655,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -3669,7 +3671,7 @@ contains nzt = min((a%icp(lcl+1)-a%icp(icl)),& & ((nza+ncd-1)/ncd)*(lcl+1-icl),& & ((nza+nrd-1)/nrd)*(lrw+1-irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) @@ -3677,12 +3679,12 @@ contains if (info /= psb_success_) return isz = min(size(ia),size(ja),size(val)) - if (present(iren)) then + if (present(iren)) then do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3698,9 +3700,9 @@ contains else do i=icl, lcl do j=a%icp(i), a%icp(i+1) - 1 - if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then nzin_ = nzin_ + 1 - if (nzin_>isz) then + if (nzin_>isz) then call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) call psb_ensure_size(int(1.25*nzin_)+ione,val,info) @@ -3720,11 +3722,11 @@ end subroutine psb_lz_csc_csgetrow -subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csput_a - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -3743,26 +3745,26 @@ subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_level = psb_get_debug_level() info = psb_success_ - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_ ierr(1)=1 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=2 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=3 call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ ierr(1)=4 call psb_errpush(info,name,i_err=ierr) @@ -3773,25 +3775,25 @@ subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_lz_csc_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -3817,7 +3819,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -3835,13 +3837,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nar = a%get_nrows() nac = a%get_ncols() @@ -3851,19 +3853,19 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -3876,18 +3878,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ic > 0).and.(ic <= nac)) then + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then i1 = a%icp(ic) i2 = a%icp(ic+1) nr = i2-i1 inr = nr - ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -3909,12 +3911,12 @@ contains end subroutine psb_lz_csc_csput_a -subroutine psb_lz_cp_csc_from_coo(a,b,info) +subroutine psb_lz_cp_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_from_coo - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b @@ -3937,11 +3939,11 @@ end subroutine psb_lz_cp_csc_from_coo -subroutine psb_lz_cp_csc_to_coo(a,b,info) +subroutine psb_lz_cp_csc_to_coo(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_to_coo - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -3971,7 +3973,7 @@ subroutine psb_lz_cp_csc_to_coo(a,b,info) b%val(j) = a%val(j) end do end do - + call b%set_nzeros(a%get_nzeros()) call b%fix(info) @@ -3979,12 +3981,12 @@ subroutine psb_lz_cp_csc_to_coo(a,b,info) end subroutine psb_lz_cp_csc_to_coo -subroutine psb_lz_mv_csc_to_coo(a,b,info) +subroutine psb_lz_mv_csc_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_to_coo - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -4021,13 +4023,13 @@ subroutine psb_lz_mv_csc_to_coo(a,b,info) end subroutine psb_lz_mv_csc_to_coo -subroutine psb_lz_mv_csc_from_coo(a,b,info) +subroutine psb_lz_mv_csc_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_from_coo - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -4051,7 +4053,7 @@ subroutine psb_lz_mv_csc_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -4074,17 +4076,17 @@ subroutine psb_lz_mv_csc_from_coo(a,b,info) end do a%icp(nc+1) = ip call a%set_host() - + end subroutine psb_lz_mv_csc_from_coo -subroutine psb_lz_mv_csc_to_fmt(a,b,info) +subroutine psb_lz_mv_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_to_fmt - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b @@ -4100,10 +4102,10 @@ subroutine psb_lz_mv_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! - type is (psb_lz_csc_sparse_mat) + ! Need to fix trivial copies! + type is (psb_lz_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat call move_alloc(a%icp, b%icp) @@ -4120,12 +4122,12 @@ subroutine psb_lz_mv_csc_to_fmt(a,b,info) end subroutine psb_lz_mv_csc_to_fmt !!$ -subroutine psb_lz_cp_csc_to_fmt(a,b,info) +subroutine psb_lz_cp_csc_to_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_to_fmt - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b @@ -4141,10 +4143,10 @@ subroutine psb_lz_cp_csc_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_lz_csc_sparse_mat) + type is (psb_lz_csc_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat nc = a%get_ncols() @@ -4162,12 +4164,12 @@ subroutine psb_lz_cp_csc_to_fmt(a,b,info) end subroutine psb_lz_cp_csc_to_fmt -subroutine psb_lz_mv_csc_from_fmt(a,b,info) +subroutine psb_lz_mv_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_from_fmt - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b @@ -4183,10 +4185,10 @@ subroutine psb_lz_mv_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_lz_csc_sparse_mat) + type is (psb_lz_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat @@ -4206,12 +4208,12 @@ end subroutine psb_lz_mv_csc_from_fmt -subroutine psb_lz_cp_csc_from_fmt(a,b,info) +subroutine psb_lz_cp_csc_from_fmt(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_from_fmt - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b @@ -4227,10 +4229,10 @@ subroutine psb_lz_cp_csc_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_lz_csc_sparse_mat) + type is (psb_lz_csc_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat nc = b%get_ncols() @@ -4245,25 +4247,25 @@ subroutine psb_lz_cp_csc_from_fmt(a,b,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select call a%set_host() - + end subroutine psb_lz_cp_csc_from_fmt subroutine psb_lz_csc_clean_zeros(a, info) use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_clean_zeros - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nc - integer(psb_lpk_), allocatable :: ilcp(:) - + integer(psb_lpk_), allocatable :: ilcp(:) + info = 0 call a%sync() nc = a%get_ncols() - ilcp = a%icp(:) + ilcp = a%icp(:) a%icp(1) = 1 - j = a%icp(1) + j = a%icp(1) do i=1, nc do k = ilcp(i), ilcp(i+1) -1 if (a%val(k) /= zzero) then @@ -4279,10 +4281,10 @@ subroutine psb_lz_csc_clean_zeros(a, info) end subroutine psb_lz_csc_clean_zeros -subroutine psb_lz_csc_mold(a,b,info) +subroutine psb_lz_csc_mold(a,b,info) use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_mold use psb_error_mod - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -4291,16 +4293,16 @@ subroutine psb_lz_csc_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_lz_csc_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -4312,11 +4314,11 @@ subroutine psb_lz_csc_mold(a,b,info) end subroutine psb_lz_csc_mold -subroutine psb_lz_csc_reallocate_nz(nz,a) +subroutine psb_lz_csc_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4328,7 +4330,7 @@ subroutine psb_lz_csc_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ia,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_ncols()+1, a%icp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -4346,7 +4348,7 @@ end subroutine psb_lz_csc_reallocate_nz subroutine psb_lz_csc_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csgetblk @@ -4369,12 +4371,12 @@ subroutine psb_lz_csc_csgetblk(imin,imax,a,b,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. endif - if (append_) then + if (append_) then nzin = a%get_nzeros() else nzin = 0 @@ -4402,9 +4404,9 @@ end subroutine psb_lz_csc_csgetblk subroutine psb_lz_csc_reinit(a,clear) use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_reinit - implicit none + implicit none - class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4418,16 +4420,16 @@ subroutine psb_lz_csc_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = zzero call a%set_upd() call a%set_host() @@ -4450,7 +4452,7 @@ subroutine psb_lz_csc_trim(a) use psb_realloc_mod use psb_error_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_trim - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, n integer(psb_ipk_) :: err_act, info, ierr(5) @@ -4465,7 +4467,7 @@ subroutine psb_lz_csc_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ia,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4475,11 +4477,11 @@ subroutine psb_lz_csc_trim(a) end subroutine psb_lz_csc_trim -subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) +subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_lz_csc_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -4490,26 +4492,26 @@ subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -4517,7 +4519,7 @@ subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(n+1,a%icp,info) if (info == psb_success_) call psb_realloc(nz_,a%ia,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%icp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -4540,24 +4542,25 @@ end subroutine psb_lz_csc_allocate_mnnz subroutine psb_lz_csc_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_csc_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) character(len=20) :: name='lz_csc_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4566,36 +4569,36 @@ subroutine psb_lz_csc_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_lz_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) iv(a%ia(j)),iv(i),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),i,a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) ivr(a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),ivc(i),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nc - do j=a%icp(i),a%icp(i+1)-1 + do j=a%icp(i),a%icp(i+1)-1 write(iout,frmt) (a%ia(j)),(i),a%val(j) end do enddo @@ -4608,7 +4611,7 @@ subroutine psb_lzcscspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_lzcscspspmm - implicit none + implicit none class(psb_lz_csc_sparse_mat), intent(in) :: a,b type(psb_lz_csc_sparse_mat), intent(out) :: c @@ -4628,7 +4631,7 @@ subroutine psb_lzcscspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -4657,9 +4660,9 @@ subroutine psb_lzcscspspmm(a,b,c,info) return contains - + subroutine csc_spspmm(a,b,c,info) - implicit none + implicit none type(psb_lz_csc_sparse_mat), intent(in) :: a,b type(psb_lz_csc_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -4682,29 +4685,29 @@ contains call psb_realloc(isz,col,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,icol,info) - if (info /= 0) return + if (info /= 0) return col = dzero icol = 0 - nzc = 1 + nzc = 1 do j = 1,nb c%icp(j) = nzc - nrc = 0 + nrc = 0 do k = b%icp(j), b%icp(j+1)-1 icl = b%ia(k) cfb = b%val(k) irwsz = a%icp(icl+1)-a%icp(icl) do i = a%icp(icl),a%icp(icl+1)-1 irw = a%ia(i) - if (icol(irw) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ia,info) @@ -4712,11 +4715,11 @@ contains end if call psb_msort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ia(nzc) = irw - c%val(nzc) = col(irw) + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) col(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index a816ed13f..f3b7b45f9 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! == =================================== ! @@ -43,11 +43,11 @@ ! ! == =================================== -subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_string_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csmv - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -73,7 +73,7 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -83,7 +83,7 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -91,16 +91,16 @@ subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_z_csr_csmm - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -418,7 +418,7 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -426,7 +426,7 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) tra = (psb_toupper(trans_) == 'T') ctra = (psb_toupper(trans_) == 'C') - if (tra.or.ctra) then + if (tra.or.ctra) then m = a%get_ncols() n = a%get_nrows() else @@ -434,16 +434,16 @@ subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() end if - if (size(x,1) psb_z_csr_cssv - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -766,7 +766,7 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -776,26 +776,26 @@ subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 end if - if (size(x) psb_z_csr_cssm - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1030,7 +1030,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) else trans_ = 'N' end if - if (.not.a%is_asb()) then + if (.not.a%is_asb()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1041,9 +1041,9 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) ctra = (psb_toupper(trans_) == 'C') m = a%get_nrows() - nc = min(size(x,2) , size(y,2)) + nc = min(size(x,2) , size(y,2)) - if (.not. (a%is_triangle())) then + if (.not. (a%is_triangle())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1063,14 +1063,14 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) return end if - if (beta == zzero) then + if (beta == zzero) then call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),y,size(y,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*y(i,1:nc) end do - else - allocate(tmp(m,nc), stat=info) + else + allocate(tmp(m,nc), stat=info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='allocate') @@ -1078,7 +1078,7 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) end if call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,& - & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) + & a%irp,a%ja,a%val,x,size(x,1,kind=psb_ipk_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc) end do @@ -1099,11 +1099,11 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) return -contains +contains subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,& - & irp,ja,val,x,ldx,y,ldy,info) - implicit none + & irp,ja,val,x,ldx,y,ldy,info) + implicit none logical, intent(in) :: tra,ctra,lower,unit integer(psb_ipk_), intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*) complex(psb_dpk_), intent(in) :: val(*), x(ldx,*) @@ -1120,38 +1120,38 @@ contains end if - if ((.not.tra).and.(.not.ctra)) then - if (lower) then - if (unit) then + if ((.not.tra).and.(.not.ctra)) then + if (lower) then + if (unit) then do i=1, nr - acc = zzero + acc = zzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr - acc = zzero + acc = zzero do j=irp(i), irp(i+1)-2 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = (x(i,1:nc) - acc)/val(irp(i+1)-1) end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then - do i=nr, 1, -1 - acc = zzero + if (unit) then + do i=nr, 1, -1 + acc = zzero do j=irp(i), irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do y(i,1:nc) = x(i,1:nc) - acc end do - else if (.not.unit) then - do i=nr, 1, -1 - acc = zzero + else if (.not.unit) then + do i=nr, 1, -1 + acc = zzero do j=irp(i)+1, irp(i+1)-1 acc = acc + val(j)*y(ja(j),1:nc) end do @@ -1161,96 +1161,96 @@ contains end if - else if (tra) then + else if (tra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/val(irp(i+1)-1) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/val(irp(i)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - val(j)*acc + y(jc,1:nc) = y(jc,1:nc) - val(j)*acc end do end do end if end if - else if (ctra) then + else if (ctra) then do i=1, nr y(i,1:nc) = x(i,1:nc) end do - if (lower) then - if (unit) then + if (lower) then + if (unit) then do i=nr, 1, -1 - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=nr, 1, -1 y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i+1)-1)) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-2 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do end if - else if (.not.lower) then + else if (.not.lower) then - if (unit) then + if (unit) then do i=1, nr - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i), irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do - else if (.not.unit) then + else if (.not.unit) then do i=1, nr y(i,1:nc) = y(i,1:nc)/conjg(val(irp(i))) - acc = y(i,1:nc) + acc = y(i,1:nc) do j=irp(i)+1, irp(i+1)-1 jc = ja(j) - y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc + y(jc,1:nc) = y(jc,1:nc) - conjg(val(j))*acc end do end do end if @@ -1264,7 +1264,7 @@ end subroutine psb_z_csr_cssm function psb_z_csr_maxval(a) result(res) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_maxval - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1277,7 +1277,7 @@ function psb_z_csr_maxval(a) result(res) res = dzero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -1286,7 +1286,7 @@ end function psb_z_csr_maxval function psb_z_csr_csnmi(a) result(res) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csnmi - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -1303,7 +1303,7 @@ function psb_z_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -1311,7 +1311,7 @@ function psb_z_csr_csnmi(a) result(res) end function psb_z_csr_csnmi -subroutine psb_z_csr_rowsum(d,a) +subroutine psb_z_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_rowsum @@ -1331,7 +1331,7 @@ subroutine psb_z_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1340,12 +1340,12 @@ subroutine psb_z_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = zzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + zone end do @@ -1353,7 +1353,7 @@ subroutine psb_z_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1361,7 +1361,7 @@ subroutine psb_z_csr_rowsum(d,a) end subroutine psb_z_csr_rowsum -subroutine psb_z_csr_arwsum(d,a) +subroutine psb_z_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_arwsum @@ -1381,7 +1381,7 @@ subroutine psb_z_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = m call psb_errpush(info,name,i_err=ierr) @@ -1391,19 +1391,19 @@ subroutine psb_z_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1411,7 +1411,7 @@ subroutine psb_z_csr_arwsum(d,a) end subroutine psb_z_csr_arwsum -subroutine psb_z_csr_colsum(d,a) +subroutine psb_z_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_colsum @@ -1432,7 +1432,7 @@ subroutine psb_z_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1447,8 +1447,8 @@ subroutine psb_z_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + zone end do @@ -1456,7 +1456,7 @@ subroutine psb_z_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1464,7 +1464,7 @@ subroutine psb_z_csr_colsum(d,a) end subroutine psb_z_csr_colsum -subroutine psb_z_csr_aclsum(d,a) +subroutine psb_z_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_aclsum @@ -1485,7 +1485,7 @@ subroutine psb_z_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ ierr(1) = 1; ierr(2) = size(d); ierr(3) = n call psb_errpush(info,name,i_err=ierr) @@ -1500,8 +1500,8 @@ subroutine psb_z_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + done end do @@ -1509,7 +1509,7 @@ subroutine psb_z_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -1517,11 +1517,11 @@ subroutine psb_z_csr_aclsum(d,a) end subroutine psb_z_csr_aclsum -subroutine psb_z_csr_get_diag(a,d,info) +subroutine psb_z_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_get_diag - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1536,28 +1536,28 @@ subroutine psb_z_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = zone else do i=1, mnm d(i) = zzero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = zzero end do @@ -1570,12 +1570,12 @@ subroutine psb_z_csr_get_diag(a,d,info) end subroutine psb_z_csr_get_diag -subroutine psb_z_csr_scal(d,a,info,side) +subroutine psb_z_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scal use psb_string_mod - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1585,47 +1585,47 @@ subroutine psb_z_csr_scal(d,a,info,side) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -1643,11 +1643,11 @@ subroutine psb_z_csr_scal(d,a,info,side) end subroutine psb_z_csr_scal -subroutine psb_z_csr_scals(d,a,info) +subroutine psb_z_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_scals - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1660,7 +1660,7 @@ subroutine psb_z_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -1680,7 +1680,7 @@ end subroutine psb_z_csr_scals -! == =================================== +! == =================================== ! ! ! @@ -1690,14 +1690,14 @@ end subroutine psb_z_csr_scals ! ! ! -! == =================================== +! == =================================== -subroutine psb_z_csr_reallocate_nz(nz,a) +subroutine psb_z_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_reallocate_nz - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1709,7 +1709,7 @@ subroutine psb_z_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -1723,10 +1723,10 @@ subroutine psb_z_csr_reallocate_nz(nz,a) end subroutine psb_z_csr_reallocate_nz -subroutine psb_z_csr_mold(a,b,info) +subroutine psb_z_csr_mold(a,b,info) use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mold use psb_error_mod - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1735,16 +1735,16 @@ subroutine psb_z_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_z_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -1755,11 +1755,11 @@ subroutine psb_z_csr_mold(a,b,info) end subroutine psb_z_csr_mold -subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_allocate_mnnz - implicit none + implicit none integer(psb_ipk_), intent(in) :: m,n class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1770,26 +1770,26 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -1797,7 +1797,7 @@ subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -1820,7 +1820,7 @@ end subroutine psb_z_csr_allocate_mnnz subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -1838,7 +1838,7 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -1866,35 +1866,35 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -1940,32 +1940,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -1976,7 +1976,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -1987,13 +1987,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_z_csr_csgetptn subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -2021,7 +2021,7 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -2040,27 +2040,27 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if (present(chksz)) then + if (present(chksz)) then chksz_ = chksz else chksz_ = .true. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -2068,13 +2068,13 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,chksz_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -2121,12 +2121,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -2134,23 +2134,23 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 - if (chksz) then + if (chksz) then call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) - + if (info /= psb_success_) return end if - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2162,7 +2162,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -2183,7 +2183,7 @@ end subroutine psb_z_csr_csgetrow ! subroutine psb_z_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_tril @@ -2195,7 +2195,7 @@ subroutine psb_z_csr_tril(a,l,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_z_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2206,57 +2206,57 @@ subroutine psb_z_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -2265,7 +2265,7 @@ subroutine psb_z_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -2281,7 +2281,7 @@ subroutine psb_z_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -2289,17 +2289,17 @@ subroutine psb_z_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -2318,8 +2318,8 @@ subroutine psb_z_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -2337,7 +2337,7 @@ end subroutine psb_z_csr_tril subroutine psb_z_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_triu @@ -2349,7 +2349,7 @@ subroutine psb_z_csr_triu(a,u,info,& integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_z_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_) :: ierr(5) @@ -2360,57 +2360,57 @@ subroutine psb_z_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -2419,7 +2419,7 @@ subroutine psb_z_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -2471,8 +2471,8 @@ subroutine psb_z_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -2489,11 +2489,11 @@ subroutine psb_z_csr_triu(a,u,info,& end subroutine psb_z_csr_triu -subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput_a - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -2511,23 +2511,23 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then + if (nz <= 0) then info = psb_err_iarg_neg_; i=1 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ia) < nz) then + if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_; i=2 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(ja) < nz) then + if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_; i=3 call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if - if (size(val) < nz) then + if (size(val) < nz) then info = psb_err_input_asize_invalid_i_; i=4 call psb_errpush(info,name,i_err=(/i/)) goto 9999 @@ -2538,25 +2538,25 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_z_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -2582,7 +2582,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -2600,13 +2600,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -2616,20 +2616,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -2641,17 +2641,17 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -2676,9 +2676,9 @@ end subroutine psb_z_csr_csput_a subroutine psb_z_csr_reinit(a,clear) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_reinit - implicit none + implicit none - class(psb_z_csr_sparse_mat), intent(inout) :: a + class(psb_z_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -2691,16 +2691,16 @@ subroutine psb_z_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = zzero call a%set_upd() call a%set_host() @@ -2723,9 +2723,9 @@ subroutine psb_z_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_trim - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz, m + integer(psb_ipk_) :: err_act, info, nz, m character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2738,7 +2738,7 @@ subroutine psb_z_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2752,10 +2752,10 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -2763,13 +2763,13 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='z_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_ipk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -2779,35 +2779,35 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) nz = a%get_nzeros() frmt = psb_z_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - write(iout,*) nr, nc, nz - if(present(iv)) then + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -2817,12 +2817,12 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_z_csr_print -subroutine psb_z_cp_csr_from_coo(a,b,info) +subroutine psb_z_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_coo - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b @@ -2840,18 +2840,18 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_z_base_sparse_mat = tmp%psb_z_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -2860,22 +2860,22 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -2891,17 +2891,17 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_z_cp_csr_from_coo -subroutine psb_z_cp_csr_to_coo(a,b,info) +subroutine psb_z_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_to_coo - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b @@ -2940,12 +2940,12 @@ subroutine psb_z_cp_csr_to_coo(a,b,info) end subroutine psb_z_cp_csr_to_coo -subroutine psb_z_mv_csr_to_coo(a,b,info) +subroutine psb_z_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_to_coo - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b @@ -2986,13 +2986,13 @@ end subroutine psb_z_mv_csr_to_coo -subroutine psb_z_mv_csr_from_coo(a,b,info) +subroutine psb_z_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_coo - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b @@ -3018,7 +3018,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -3042,15 +3042,15 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_z_mv_csr_from_coo -subroutine psb_z_mv_csr_to_fmt(a,b,info) +subroutine psb_z_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_to_fmt - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b @@ -3067,9 +3067,9 @@ subroutine psb_z_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_z_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat @@ -3087,12 +3087,12 @@ subroutine psb_z_mv_csr_to_fmt(a,b,info) end subroutine psb_z_mv_csr_to_fmt -subroutine psb_z_cp_csr_to_fmt(a,b,info) +subroutine psb_z_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_to_fmt - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b @@ -3110,10 +3110,10 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_z_csr_sparse_mat) + type is (psb_z_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat nr = a%get_nrows() @@ -3131,11 +3131,11 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info) end subroutine psb_z_cp_csr_to_fmt -subroutine psb_z_mv_csr_from_fmt(a,b,info) +subroutine psb_z_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_mv_csr_from_fmt - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b @@ -3152,10 +3152,10 @@ subroutine psb_z_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_z_csr_sparse_mat) + type is (psb_z_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat @@ -3174,12 +3174,12 @@ end subroutine psb_z_mv_csr_from_fmt -subroutine psb_z_cp_csr_from_fmt(a,b,info) +subroutine psb_z_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_cp_csr_from_fmt - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b @@ -3196,10 +3196,10 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_z_coo_sparse_mat) + type is (psb_z_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_z_csr_sparse_mat) + type is (psb_z_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat nr = b%get_nrows() @@ -3218,19 +3218,19 @@ end subroutine psb_z_cp_csr_from_fmt subroutine psb_z_csr_clean_zeros(a, info) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_clean_zeros - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_ipk_) :: i, j, k, nr - integer(psb_ipk_), allocatable :: ilrp(:) - + integer(psb_ipk_), allocatable :: ilrp(:) + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= zzero) then @@ -3249,7 +3249,7 @@ subroutine psb_zcsrspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_zcsrspspmm - implicit none + implicit none class(psb_z_csr_sparse_mat), intent(in) :: a,b type(psb_z_csr_sparse_mat), intent(out) :: c @@ -3260,7 +3260,7 @@ subroutine psb_zcsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -3270,7 +3270,7 @@ subroutine psb_zcsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -3296,9 +3296,9 @@ subroutine psb_zcsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_z_csr_sparse_mat), intent(in) :: a,b type(psb_z_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -3321,49 +3321,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_zcsrspspmm @@ -3372,13 +3372,13 @@ end subroutine psb_zcsrspspmm ! ! ! lz version -! ! -subroutine psb_lz_csr_get_diag(a,d,info) +! +subroutine psb_lz_csr_get_diag(a,d,info) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_get_diag - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3393,28 +3393,28 @@ subroutine psb_lz_csr_get_diag(a,d,info) if (a%is_dev()) call a%sync() mnm = min(a%get_nrows(),a%get_ncols()) - if (size(d) < mnm) then + if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - if (a%is_unit()) then + if (a%is_unit()) then d(1:mnm) = zone else do i=1, mnm d(i) = zzero do k=a%irp(i),a%irp(i+1)-1 j=a%ja(k) - if ((j == i) .and.(j <= mnm )) then + if ((j == i) .and.(j <= mnm )) then d(i) = a%val(k) endif enddo end do end if - do i=mnm+1,size(d) + do i=mnm+1,size(d) d(i) = zzero end do @@ -3427,12 +3427,12 @@ subroutine psb_lz_csr_get_diag(a,d,info) end subroutine psb_lz_csr_get_diag -subroutine psb_lz_csr_scal(d,a,info,side) +subroutine psb_lz_csr_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_scal use psb_string_mod - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -3442,47 +3442,47 @@ subroutine psb_lz_csr_scal(d,a,info,side) integer(psb_ipk_) :: err_act, ierr(5) character(len=20) :: name='scal' character :: side_ - logical :: left + logical :: left logical, parameter :: debug=.false. info = psb_success_ call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if side_ = 'L' - if (present(side)) then + if (present(side)) then side_ = psb_toupper(side) end if left = (side_ == 'L') - if (left) then + if (left) then m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - - do i=1, m - do j = a%irp(i), a%irp(i+1) -1 + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 a%val(j) = a%val(j) * d(i) end do enddo else m = a%get_ncols() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); + ierr(1) = 2; ierr(2) = size(d); call psb_errpush(info,name,i_err=ierr) goto 9999 end if - + do i=1,a%get_nzeros() j = a%ja(i) a%val(i) = a%val(i) * d(j) @@ -3500,11 +3500,11 @@ subroutine psb_lz_csr_scal(d,a,info,side) end subroutine psb_lz_csr_scal -subroutine psb_lz_csr_scals(d,a,info) +subroutine psb_lz_csr_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_scals - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -3518,7 +3518,7 @@ subroutine psb_lz_csr_scals(d,a,info) call psb_erractionsave(err_act) if (a%is_dev()) call a%sync() - if (a%is_unit()) then + if (a%is_unit()) then call a%make_nonunit() end if @@ -3539,7 +3539,7 @@ end subroutine psb_lz_csr_scals function psb_lz_csr_maxval(a) result(res) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_maxval - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3552,7 +3552,7 @@ function psb_lz_csr_maxval(a) result(res) res = dzero nnz = a%get_nzeros() - if (allocated(a%val)) then + if (allocated(a%val)) then nnz = min(nnz,size(a%val)) res = maxval(abs(a%val(1:nnz))) end if @@ -3561,7 +3561,7 @@ end function psb_lz_csr_maxval function psb_lz_csr_csnmi(a) result(res) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csnmi - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res @@ -3578,7 +3578,7 @@ function psb_lz_csr_csnmi(a) result(res) do i = 1, a%get_nrows() acc = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do res = max(res,acc) @@ -3586,7 +3586,7 @@ function psb_lz_csr_csnmi(a) result(res) end function psb_lz_csr_csnmi -subroutine psb_lz_csr_rowsum(d,a) +subroutine psb_lz_csr_rowsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_rowsum @@ -3606,7 +3606,7 @@ subroutine psb_lz_csr_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3615,12 +3615,12 @@ subroutine psb_lz_csr_rowsum(d,a) do i = 1, a%get_nrows() d(i) = zzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + zone end do @@ -3628,7 +3628,7 @@ subroutine psb_lz_csr_rowsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3636,7 +3636,7 @@ subroutine psb_lz_csr_rowsum(d,a) end subroutine psb_lz_csr_rowsum -subroutine psb_lz_csr_arwsum(d,a) +subroutine psb_lz_csr_arwsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_arwsum @@ -3656,7 +3656,7 @@ subroutine psb_lz_csr_arwsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() - if (size(d) < m) then + if (size(d) < m) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = m call psb_errpush(info,name,e_err=err) @@ -3666,19 +3666,19 @@ subroutine psb_lz_csr_arwsum(d,a) do i = 1, a%get_nrows() d(i) = dzero - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 d(i) = d(i) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, m d(i) = d(i) + done end do end if call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3686,7 +3686,7 @@ subroutine psb_lz_csr_arwsum(d,a) end subroutine psb_lz_csr_arwsum -subroutine psb_lz_csr_colsum(d,a) +subroutine psb_lz_csr_colsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_colsum @@ -3707,7 +3707,7 @@ subroutine psb_lz_csr_colsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3722,8 +3722,8 @@ subroutine psb_lz_csr_colsum(d,a) d(k) = d(k) + (a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + zone end do @@ -3731,7 +3731,7 @@ subroutine psb_lz_csr_colsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3739,7 +3739,7 @@ subroutine psb_lz_csr_colsum(d,a) end subroutine psb_lz_csr_colsum -subroutine psb_lz_csr_aclsum(d,a) +subroutine psb_lz_csr_aclsum(d,a) use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_aclsum @@ -3760,7 +3760,7 @@ subroutine psb_lz_csr_aclsum(d,a) m = a%get_nrows() n = a%get_ncols() - if (size(d) < n) then + if (size(d) < n) then info=psb_err_input_asize_small_i_ err(1) = 1; err(2) = size(d); err(3) = n call psb_errpush(info,name,e_err=err) @@ -3775,8 +3775,8 @@ subroutine psb_lz_csr_aclsum(d,a) d(k) = d(k) + abs(a%val(j)) end do end do - - if (a%is_unit()) then + + if (a%is_unit()) then do i=1, n d(i) = d(i) + done end do @@ -3784,7 +3784,7 @@ subroutine psb_lz_csr_aclsum(d,a) return call psb_erractionrestore(err_act) - return + return 9999 call psb_error_handler(err_act) @@ -3793,7 +3793,7 @@ subroutine psb_lz_csr_aclsum(d,a) end subroutine psb_lz_csr_aclsum -! == =================================== +! == =================================== ! ! ! @@ -3803,14 +3803,14 @@ end subroutine psb_lz_csr_aclsum ! ! ! -! == =================================== +! == =================================== -subroutine psb_lz_csr_reallocate_nz(nz,a) +subroutine psb_lz_csr_reallocate_nz(nz,a) use psb_error_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_reallocate_nz - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lz_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3822,7 +3822,7 @@ subroutine psb_lz_csr_reallocate_nz(nz,a) call psb_realloc(max(nz,ione),a%ja,info) if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) if (info == psb_success_) call psb_realloc(a%get_nrows()+1,a%irp,info) - if (info /= psb_success_) then + if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) goto 9999 end if @@ -3836,10 +3836,10 @@ subroutine psb_lz_csr_reallocate_nz(nz,a) end subroutine psb_lz_csr_reallocate_nz -subroutine psb_lz_csr_mold(a,b,info) +subroutine psb_lz_csr_mold(a,b,info) use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_mold use psb_error_mod - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -3848,16 +3848,16 @@ subroutine psb_lz_csr_mold(a,b,info) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - - info = 0 - if (allocated(b)) then + + info = 0 + if (allocated(b)) then call b%free() deallocate(b,stat=info) end if if (info == 0) allocate(psb_lz_csr_sparse_mat :: b, stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if @@ -3868,11 +3868,11 @@ subroutine psb_lz_csr_mold(a,b,info) end subroutine psb_lz_csr_mold -subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) +subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_allocate_mnnz - implicit none + implicit none integer(psb_lpk_), intent(in) :: m,n class(psb_lz_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in), optional :: nz @@ -3884,26 +3884,26 @@ subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) call psb_erractionsave(err_act) info = psb_success_ - if (m < 0) then + if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; + ierr(1) = ione; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (n < 0) then + if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; + ierr(1) = 2; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif - if (present(nz)) then + if (present(nz)) then nz_ = max(nz,ione) else nz_ = max(7*m,7*n,ione) end if - if (nz_ < 0) then + if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; + ierr(1) = 3; ierr(2) = izero; call psb_errpush(info,name,i_err=ierr) goto 9999 endif @@ -3911,7 +3911,7 @@ subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) if (info == psb_success_) call psb_realloc(m+1,a%irp,info) if (info == psb_success_) call psb_realloc(nz_,a%ja,info) if (info == psb_success_) call psb_realloc(nz_,a%val,info) - if (info == psb_success_) then + if (info == psb_success_) then a%irp=0 call a%set_nrows(m) call a%set_ncols(n) @@ -3934,7 +3934,7 @@ end subroutine psb_lz_csr_allocate_mnnz subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -3952,7 +3952,7 @@ subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -3981,35 +3981,35 @@ subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 end if call csr_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4055,32 +4055,32 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 endif ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = iren(i) @@ -4091,7 +4091,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 ia(nzin_) = (i) @@ -4102,13 +4102,13 @@ contains end if end subroutine csr_getptn - + end subroutine psb_lz_csr_csgetptn subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_error_mod @@ -4127,7 +4127,7 @@ subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale - logical :: append_, rscale_, cscale_ + logical :: append_, rscale_, cscale_ integer(psb_lpk_) :: nzin_, jmin_, jmax_, i integer(psb_ipk_) :: err_act character(len=20) :: name='csget' @@ -4137,7 +4137,7 @@ subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& if (a%is_dev()) call a%sync() info = psb_success_ nz = 0 - + if (present(jmin)) then jmin_ = jmin else @@ -4156,22 +4156,22 @@ subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& else append_=.false. endif - if ((append_).and.(present(nzin))) then + if ((append_).and.(present(nzin))) then nzin_ = nzin else nzin_ = 0 endif - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .false. endif - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .false. endif - if ((rscale_.or.cscale_).and.(present(iren))) then + if ((rscale_.or.cscale_).and.(present(iren))) then info = psb_err_many_optional_arg_ call psb_errpush(info,name,a_err='iren (rscale.or.cscale)') goto 9999 @@ -4179,13 +4179,13 @@ subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call csr_getrow(imin,imax,jmin_,jmax_,a,nz,ia,ja,val,nzin_,append_,info,& & iren) - - if (rscale_) then + + if (rscale_) then do i=nzin_+1, nzin_+nz ia(i) = ia(i) - imin + 1 end do end if - if (cscale_) then + if (cscale_) then do i=nzin_+1, nzin_+nz ja(i) = ja(i) - jmin_ + 1 end do @@ -4232,12 +4232,12 @@ contains lrw = min(imax,a%get_nrows()) icl = jmin lcl = min(jmax,a%get_ncols()) - if (irw<0) then + if (irw<0) then info = psb_err_pivot_too_small_ return end if - if (append) then + if (append) then nzin_ = nzin else nzin_ = 0 @@ -4245,21 +4245,21 @@ contains ! ! This is a row-oriented routine, so the following is a - ! good choice. + ! good choice. ! nzt = (a%irp(lrw+1)-a%irp(irw)) - nz = 0 + nz = 0 call psb_ensure_size(nzin_+nzt,ia,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) if (info /= psb_success_) return - - if (present(iren)) then + + if (present(iren)) then do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4271,7 +4271,7 @@ contains else do i=irw, lrw do j=a%irp(i), a%irp(i+1) - 1 - if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then + if ((jmin <= a%ja(j)).and.(a%ja(j)<=jmax)) then nzin_ = nzin_ + 1 nz = nz + 1 val(nzin_) = a%val(j) @@ -4292,7 +4292,7 @@ end subroutine psb_lz_csr_csgetrow ! subroutine psb_lz_csr_tril(a,l,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,u) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_tril @@ -4304,7 +4304,7 @@ subroutine psb_lz_csr_tril(a,l,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lz_coo_sparse_mat), optional, intent(out) :: u - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4316,57 +4316,57 @@ subroutine psb_lz_csr_tril(a,l,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call l%allocate(mb,nb,nz) - + if (present(u)) then nzlin = l%get_nzeros() ! At this point it should be 0 call u%allocate(mb,nb,nz) @@ -4375,7 +4375,7 @@ subroutine psb_lz_csr_tril(a,l,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzlin = nzlin + 1 l%ia(nzlin) = i @@ -4391,7 +4391,7 @@ subroutine psb_lz_csr_tril(a,l,info,& end do end do end associate - + call l%set_nzeros(nzlin) call u%set_nzeros(nzuin) call u%fix(info) @@ -4399,17 +4399,17 @@ subroutine psb_lz_csr_tril(a,l,info,& if (rscale_) & & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & - & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - if ((diag_ >=-1).and.(imin_ == jmin_)) then + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_lower(.false.) end if else nzin = l%get_nzeros() ! At this point it should be 0 associate(val =>a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)<=diag_) then nzin = nzin + 1 l%ia(nzin) = i @@ -4428,8 +4428,8 @@ subroutine psb_lz_csr_tril(a,l,info,& & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 if (cscale_) & & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 - - if ((diag_ <= 0).and.(imin_ == jmin_)) then + + if ((diag_ <= 0).and.(imin_ == jmin_)) then call l%set_triangle(.true.) call l%set_lower(.true.) end if @@ -4447,7 +4447,7 @@ end subroutine psb_lz_csr_tril subroutine psb_lz_csr_triu(a,u,info,& & diag,imin,imax,jmin,jmax,rscale,cscale,l) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_triu @@ -4459,7 +4459,7 @@ subroutine psb_lz_csr_triu(a,u,info,& integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale class(psb_lz_coo_sparse_mat), optional, intent(out) :: l - + integer(psb_ipk_) :: err_act integer(psb_lpk_) :: nzin, nzout, i, j, k integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz @@ -4471,57 +4471,57 @@ subroutine psb_lz_csr_triu(a,u,info,& call psb_erractionsave(err_act) info = psb_success_ - if (present(diag)) then + if (present(diag)) then diag_ = diag else diag_ = 0 end if - if (present(imin)) then + if (present(imin)) then imin_ = imin else imin_ = 1 end if - if (present(imax)) then + if (present(imax)) then imax_ = imax else imax_ = a%get_nrows() end if - if (present(jmin)) then + if (present(jmin)) then jmin_ = jmin else jmin_ = 1 end if - if (present(jmax)) then + if (present(jmax)) then jmax_ = jmax else jmax_ = a%get_ncols() end if - if (present(rscale)) then + if (present(rscale)) then rscale_ = rscale else rscale_ = .true. end if - if (present(cscale)) then + if (present(cscale)) then cscale_ = cscale else cscale_ = .true. end if - if (rscale_) then + if (rscale_) then mb = imax_ - imin_ +1 - else - mb = imax_ + else + mb = imax_ endif - if (cscale_) then + if (cscale_) then nb = jmax_ - jmin_ +1 - else - nb = jmax_ + else + nb = jmax_ endif nz = a%get_nzeros() call u%allocate(mb,nb,nz) - + if (present(l)) then nzuin = u%get_nzeros() ! At this point it should be 0 call l%allocate(mb,nb,nz) @@ -4530,7 +4530,7 @@ subroutine psb_lz_csr_triu(a,u,info,& do i=imin_,imax_ do k=irp(i),irp(i+1)-1 j = ja(k) - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) - do i=imin_,imax_ + do i=imin_,imax_ do k=irp(i),irp(i+1)-1 - if ((jmin_<=j).and.(j<=jmax_)) then + if ((jmin_<=j).and.(j<=jmax_)) then if ((ja(k)-i)>=diag_) then nzin = nzin + 1 u%ia(nzin) = i @@ -4582,8 +4582,8 @@ subroutine psb_lz_csr_triu(a,u,info,& & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 if (cscale_) & & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 - - if ((diag_ >= 0).and.(imin_ == jmin_)) then + + if ((diag_ >= 0).and.(imin_ == jmin_)) then call u%set_triangle(.true.) call u%set_upper(.true.) end if @@ -4600,11 +4600,11 @@ subroutine psb_lz_csr_triu(a,u,info,& end subroutine psb_lz_csr_triu -subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_error_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csput_a - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) @@ -4624,24 +4624,24 @@ subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (nz <= 0) then - info = psb_err_iarg_neg_; + if (nz <= 0) then + info = psb_err_iarg_neg_; call psb_errpush(info,name,m_err=(/1/)) goto 9999 end if - if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/2/)) goto 9999 end if - if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/3/)) goto 9999 end if - if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_; + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; call psb_errpush(info,name,m_err=(/4/)) goto 9999 end if @@ -4651,25 +4651,25 @@ subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) nza = a%get_nzeros() - if (a%is_bld()) then + if (a%is_bld()) then ! Build phase should only ever be in COO info = psb_err_invalid_mat_state_ - else if (a%is_upd()) then + else if (a%is_upd()) then call psb_lz_csr_srch_upd(nz,ia,ja,val,a,& & imin,imax,jmin,jmax,info) - if (info < 0) then + if (info < 0) then info = psb_err_internal_error_ - else if (info > 0) then + else if (info > 0) then if (debug_level >= psb_debug_serial_) & & write(debug_unit,*) trim(name),& - & ': Discarded entries not belonging to us.' + & ': Discarded entries not belonging to us.' info = psb_success_ end if call a%set_host() - else + else ! State is wrong. info = psb_err_invalid_mat_state_ end if @@ -4695,7 +4695,7 @@ contains use psb_realloc_mod use psb_string_mod use psb_sort_mod - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax @@ -4713,13 +4713,13 @@ contains dupl = a%get_dupl() - if (.not.a%is_sorted()) then + if (.not.a%is_sorted()) then info = -4 return end if - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 nnz = a%get_nzeros() nr = a%get_nrows() nc = a%get_ncols() @@ -4729,20 +4729,20 @@ contains ! Overwrite. ! Cannot test for error, should have been caught earlier. - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) + ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc=i2-i1 inc = nc - ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then a%val(i1+ip-1) = val(i) else info = max(info,3) @@ -4754,18 +4754,18 @@ contains case(psb_dupl_add_) ! Add - ilr = -1 - ilc = -1 + ilr = -1 + ilc = -1 do i=1, nz ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= nr)) then + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 inc = nc ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) - if (ip>0) then + if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else info = max(info,3) @@ -4790,9 +4790,9 @@ end subroutine psb_lz_csr_csput_a subroutine psb_lz_csr_reinit(a,clear) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_reinit - implicit none + implicit none - class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info @@ -4805,16 +4805,16 @@ subroutine psb_lz_csr_reinit(a,clear) if (a%is_dev()) call a%sync() - if (present(clear)) then + if (present(clear)) then clear_ = clear else clear_ = .true. end if - if (a%is_bld() .or. a%is_upd()) then + if (a%is_bld() .or. a%is_upd()) then ! do nothing return - else if (a%is_asb()) then + else if (a%is_asb()) then if (clear_) a%val(:) = zzero call a%set_upd() call a%set_host() @@ -4837,7 +4837,7 @@ subroutine psb_lz_csr_trim(a) use psb_realloc_mod use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_trim - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a integer(psb_lpk_) :: nz, m integer(psb_ipk_) :: err_act, info @@ -4853,7 +4853,7 @@ subroutine psb_lz_csr_trim(a) if (info == psb_success_) call psb_realloc(nz,a%ja,info) if (info == psb_success_) call psb_realloc(nz,a%val,info) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4866,10 +4866,10 @@ end subroutine psb_lz_csr_trim subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) use psb_string_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_print - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_csr_sparse_mat), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -4877,13 +4877,13 @@ subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_) :: err_act character(len=20) :: name='lz_csr_print' logical, parameter :: debug=.false. - character(len=80) :: frmt + character(len=80) :: frmt integer(psb_lpk_) :: irs,ics,i,j, ni, nr, nc, nz - + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - if (present(head)) write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' write(iout,'(a,a)') '% COO' if (a%is_dev()) call a%sync() @@ -4892,36 +4892,36 @@ subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) nc = a%get_ncols() nz = a%get_nzeros() frmt = psb_lz_get_print_frmt(nr,nc,nz,iv,ivr,ivc) - - write(iout,*) nr, nc, nz - if(present(iv)) then + + write(iout,*) nr, nc, nz + if(present(iv)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) iv(i),iv(a%ja(j)),a%val(j) end do enddo - else - if (present(ivr).and..not.present(ivc)) then + else + if (present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),(a%ja(j)),a%val(j) end do enddo - else if (present(ivr).and.present(ivc)) then + else if (present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) ivr(i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and.present(ivc)) then + else if (.not.present(ivr).and.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),ivc(a%ja(j)),a%val(j) end do enddo - else if (.not.present(ivr).and..not.present(ivc)) then + else if (.not.present(ivr).and..not.present(ivc)) then do i=1, nr - do j=a%irp(i),a%irp(i+1)-1 + do j=a%irp(i),a%irp(i+1)-1 write(iout,frmt) (i),(a%ja(j)),a%val(j) end do enddo @@ -4931,12 +4931,12 @@ subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) end subroutine psb_lz_csr_print -subroutine psb_lz_cp_csr_from_coo(a,b,info) +subroutine psb_lz_cp_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_from_coo - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(in) :: b @@ -4954,18 +4954,18 @@ subroutine psb_lz_cp_csr_from_coo(a,b,info) info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - - if (.not.b%is_by_rows()) then + + if (.not.b%is_by_rows()) then ! This is to have fix_coo called behind the scenes call tmp%cp_from_coo(b,info) if (info /= psb_success_) return - + nr = tmp%get_nrows() nc = tmp%get_ncols() nza = tmp%get_nzeros() - + a%psb_lz_base_sparse_mat = tmp%psb_lz_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(tmp%ia,itemp) call move_alloc(tmp%ja,a%ja) @@ -4974,22 +4974,22 @@ subroutine psb_lz_cp_csr_from_coo(a,b,info) call tmp%free() else - + if (info /= psb_success_) return if (b%is_dev()) call b%sync() - + nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat - + ! Dirty trick: call move_alloc to have the new data allocated just once. call psb_safe_ab_cpy(b%ia,itemp,info) if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) if (info == psb_success_) call psb_realloc(nr+1,a%irp,info) - + endif a%irp(:) = 0 @@ -5005,17 +5005,17 @@ subroutine psb_lz_cp_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_lz_cp_csr_from_coo -subroutine psb_lz_cp_csr_to_coo(a,b,info) +subroutine psb_lz_cp_csr_to_coo(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_to_coo - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -5054,12 +5054,12 @@ subroutine psb_lz_cp_csr_to_coo(a,b,info) end subroutine psb_lz_cp_csr_to_coo -subroutine psb_lz_mv_csr_to_coo(a,b,info) +subroutine psb_lz_mv_csr_to_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_to_coo - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -5100,13 +5100,13 @@ end subroutine psb_lz_mv_csr_to_coo -subroutine psb_lz_mv_csr_from_coo(a,b,info) +subroutine psb_lz_mv_csr_from_coo(a,b,info) use psb_const_mod use psb_realloc_mod use psb_error_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_from_coo - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_coo_sparse_mat), intent(inout) :: b @@ -5132,7 +5132,7 @@ subroutine psb_lz_mv_csr_from_coo(a,b,info) nr = b%get_nrows() nc = b%get_ncols() nza = b%get_nzeros() - + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat ! Dirty trick: call move_alloc to have the new data allocated just once. @@ -5156,15 +5156,15 @@ subroutine psb_lz_mv_csr_from_coo(a,b,info) end do a%irp(nr+1) = ip call a%set_host() - + end subroutine psb_lz_mv_csr_from_coo -subroutine psb_lz_mv_csr_to_fmt(a,b,info) +subroutine psb_lz_mv_csr_to_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_to_fmt - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b @@ -5181,9 +5181,9 @@ subroutine psb_lz_mv_csr_to_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%mv_to_coo(b,info) - ! Need to fix trivial copies! + ! Need to fix trivial copies! type is (psb_lz_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat @@ -5201,12 +5201,12 @@ subroutine psb_lz_mv_csr_to_fmt(a,b,info) end subroutine psb_lz_mv_csr_to_fmt -subroutine psb_lz_cp_csr_to_fmt(a,b,info) +subroutine psb_lz_cp_csr_to_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_to_fmt - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b @@ -5224,10 +5224,10 @@ subroutine psb_lz_cp_csr_to_fmt(a,b,info) select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%cp_to_coo(b,info) - type is (psb_lz_csr_sparse_mat) + type is (psb_lz_csr_sparse_mat) if (a%is_dev()) call a%sync() b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat nr = a%get_nrows() @@ -5245,11 +5245,11 @@ subroutine psb_lz_cp_csr_to_fmt(a,b,info) end subroutine psb_lz_cp_csr_to_fmt -subroutine psb_lz_mv_csr_from_fmt(a,b,info) +subroutine psb_lz_mv_csr_from_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_from_fmt - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b @@ -5266,10 +5266,10 @@ subroutine psb_lz_mv_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%mv_from_coo(b,info) - type is (psb_lz_csr_sparse_mat) + type is (psb_lz_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat @@ -5288,12 +5288,12 @@ end subroutine psb_lz_mv_csr_from_fmt -subroutine psb_lz_cp_csr_from_fmt(a,b,info) +subroutine psb_lz_cp_csr_from_fmt(a,b,info) use psb_const_mod use psb_z_base_mat_mod use psb_realloc_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_from_fmt - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(in) :: b @@ -5310,10 +5310,10 @@ subroutine psb_lz_cp_csr_from_fmt(a,b,info) info = psb_success_ select type (b) - type is (psb_lz_coo_sparse_mat) + type is (psb_lz_coo_sparse_mat) call a%cp_from_coo(b,info) - type is (psb_lz_csr_sparse_mat) + type is (psb_lz_csr_sparse_mat) if (b%is_dev()) call b%sync() a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat nr = b%get_nrows() @@ -5333,19 +5333,19 @@ end subroutine psb_lz_cp_csr_from_fmt subroutine psb_lz_csr_clean_zeros(a, info) use psb_error_mod use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_clean_zeros - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: info ! integer(psb_lpk_) :: i, j, k, nr - integer(psb_lpk_), allocatable :: ilrp(:) - - info = 0 + integer(psb_lpk_), allocatable :: ilrp(:) + + info = 0 call a%sync() nr = a%get_nrows() - ilrp = a%irp(:) + ilrp = a%irp(:) a%irp(1) = 1 - j = a%irp(1) + j = a%irp(1) do i=1, nr do k = ilrp(i), ilrp(i+1) -1 if (a%val(k) /= zzero) then @@ -5364,7 +5364,7 @@ subroutine psb_lzcsrspspmm(a,b,c,info) use psb_z_mat_mod use psb_serial_mod, psb_protect_name => psb_lzcsrspspmm - implicit none + implicit none class(psb_lz_csr_sparse_mat), intent(in) :: a,b type(psb_lz_csr_sparse_mat), intent(out) :: c @@ -5375,7 +5375,7 @@ subroutine psb_lzcsrspspmm(a,b,c,info) name='psb_csrspspmm' call psb_erractionsave(err_act) info = psb_success_ - + if (a%is_dev()) call a%sync() if (b%is_dev()) call b%sync() @@ -5385,7 +5385,7 @@ subroutine psb_lzcsrspspmm(a,b,c,info) nb = b%get_ncols() - if ( mb /= na ) then + if ( mb /= na ) then write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb info = psb_err_invalid_matrix_sizes_ call psb_errpush(info,name) @@ -5410,9 +5410,9 @@ subroutine psb_lzcsrspspmm(a,b,c,info) return contains - + subroutine csr_spspmm(a,b,c,info) - implicit none + implicit none type(psb_lz_csr_sparse_mat), intent(in) :: a,b type(psb_lz_csr_sparse_mat), intent(inout) :: c integer(psb_ipk_), intent(out) :: info @@ -5435,50 +5435,49 @@ contains call psb_realloc(isz,row,info) if (info == 0) call psb_realloc(isz,idxs,info) if (info == 0) call psb_realloc(isz,irow,info) - if (info /= 0) return + if (info /= 0) return row = dzero irow = 0 - nzc = 1 + nzc = 1 do j = 1,ma c%irp(j) = nzc - nrc = 0 + nrc = 0 do k = a%irp(j), a%irp(j+1)-1 irw = a%ja(k) cfb = a%val(k) irwsz = b%irp(irw+1)-b%irp(irw) do i = b%irp(irw),b%irp(irw+1)-1 icl = b%ja(i) - if (irow(icl) 0 ) then - if ((nzc+nrc)>nze) then + if (nrc > 0 ) then + if ((nzc+nrc)>nze) then nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) call psb_realloc(nze,c%val,info) if (info == 0) call psb_realloc(nze,c%ja,info) if (info /= 0) return end if - + call psb_qsort(idxs(1:nrc)) do i=1, nrc - irw = idxs(i) - c%ja(nzc) = irw - c%val(nzc) = row(irw) + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) row(irw) = dzero - nzc = nzc + 1 + nzc = nzc + 1 end do end if end do c%irp(ma+1) = nzc - + end subroutine csr_spspmm end subroutine psb_lzcsrspspmm - diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index ab7ce98a1..07616c05d 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,8 +27,8 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! ! ! z_mat_impl: ! implementation of the outer matrix methods. @@ -43,7 +43,7 @@ ! ! ! -! Setters +! Setters ! ! ! @@ -53,10 +53,10 @@ ! == =================================== -subroutine psb_z_set_nrows(m,a) +subroutine psb_z_set_nrows(m,a) use psb_z_mat_mod, psb_protect_name => psb_z_set_nrows use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -64,7 +64,7 @@ subroutine psb_z_set_nrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -82,10 +82,10 @@ subroutine psb_z_set_nrows(m,a) end subroutine psb_z_set_nrows -subroutine psb_z_set_ncols(n,a) +subroutine psb_z_set_ncols(n,a) use psb_z_mat_mod, psb_protect_name => psb_z_set_ncols use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -93,7 +93,7 @@ subroutine psb_z_set_ncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -112,16 +112,16 @@ end subroutine psb_z_set_ncols ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_z_set_dupl(n,a) +subroutine psb_z_set_dupl(n,a) use psb_z_mat_mod, psb_protect_name => psb_z_set_dupl use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -129,7 +129,7 @@ subroutine psb_z_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -151,17 +151,17 @@ end subroutine psb_z_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_z_set_null(a) +subroutine psb_z_set_null(a) use psb_z_mat_mod, psb_protect_name => psb_z_set_null use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -179,17 +179,17 @@ subroutine psb_z_set_null(a) end subroutine psb_z_set_null -subroutine psb_z_set_bld(a) +subroutine psb_z_set_bld(a) use psb_z_mat_mod, psb_protect_name => psb_z_set_bld use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -208,17 +208,17 @@ subroutine psb_z_set_bld(a) end subroutine psb_z_set_bld -subroutine psb_z_set_upd(a) +subroutine psb_z_set_upd(a) use psb_z_mat_mod, psb_protect_name => psb_z_set_upd use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -238,17 +238,17 @@ subroutine psb_z_set_upd(a) end subroutine psb_z_set_upd -subroutine psb_z_set_asb(a) +subroutine psb_z_set_asb(a) use psb_z_mat_mod, psb_protect_name => psb_z_set_asb use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -267,10 +267,10 @@ subroutine psb_z_set_asb(a) end subroutine psb_z_set_asb -subroutine psb_z_set_sorted(a,val) +subroutine psb_z_set_sorted(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_sorted use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -278,7 +278,7 @@ subroutine psb_z_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -297,10 +297,10 @@ subroutine psb_z_set_sorted(a,val) end subroutine psb_z_set_sorted -subroutine psb_z_set_triangle(a,val) +subroutine psb_z_set_triangle(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_triangle use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -308,7 +308,7 @@ subroutine psb_z_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -326,10 +326,10 @@ subroutine psb_z_set_triangle(a,val) end subroutine psb_z_set_triangle -subroutine psb_z_set_symmetric(a,val) +subroutine psb_z_set_symmetric(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -337,7 +337,7 @@ subroutine psb_z_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -355,10 +355,10 @@ subroutine psb_z_set_symmetric(a,val) end subroutine psb_z_set_symmetric -subroutine psb_z_set_unit(a,val) +subroutine psb_z_set_unit(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_unit use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -366,7 +366,7 @@ subroutine psb_z_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -385,10 +385,10 @@ subroutine psb_z_set_unit(a,val) end subroutine psb_z_set_unit -subroutine psb_z_set_lower(a,val) +subroutine psb_z_set_lower(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_lower use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -396,7 +396,7 @@ subroutine psb_z_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -415,10 +415,10 @@ subroutine psb_z_set_lower(a,val) end subroutine psb_z_set_lower -subroutine psb_z_set_upper(a,val) +subroutine psb_z_set_upper(a,val) use psb_z_mat_mod, psb_protect_name => psb_z_set_upper use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -426,7 +426,7 @@ subroutine psb_z_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -456,16 +456,16 @@ end subroutine psb_z_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) use psb_z_mat_mod, psb_protect_name => psb_z_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -476,7 +476,7 @@ subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -496,10 +496,10 @@ end subroutine psb_z_sparse_print subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_z_mat_mod, psb_protect_name => psb_z_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_zspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_zspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -511,24 +511,24 @@ subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -547,13 +547,13 @@ end subroutine psb_z_n_sparse_print subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) use psb_z_mat_mod, psb_protect_name => psb_z_get_neigh use psb_error_mod - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n integer(psb_ipk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev + integer(psb_ipk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -561,7 +561,7 @@ subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -582,17 +582,17 @@ end subroutine psb_z_get_neigh -subroutine psb_z_csall(nr,nc,a,info,nz) +subroutine psb_z_csall(nr,nc,a,info,nz) use psb_z_mat_mod, psb_protect_name => psb_z_csall use psb_z_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -602,13 +602,13 @@ subroutine psb_z_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_z_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -619,10 +619,10 @@ subroutine psb_z_csall(nr,nc,a,info,nz) end subroutine psb_z_csall -subroutine psb_z_reallocate_nz(nz,a) +subroutine psb_z_reallocate_nz(nz,a) use psb_z_mat_mod, psb_protect_name => psb_z_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: nz class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -630,7 +630,7 @@ subroutine psb_z_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -647,31 +647,31 @@ subroutine psb_z_reallocate_nz(nz,a) end subroutine psb_z_reallocate_nz -subroutine psb_z_free(a) +subroutine psb_z_free(a) use psb_z_mat_mod, psb_protect_name => psb_z_free use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_z_free -subroutine psb_z_trim(a) +subroutine psb_z_trim(a) use psb_z_mat_mod, psb_protect_name => psb_z_trim use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -689,11 +689,11 @@ end subroutine psb_z_trim -subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_mat_mod, psb_protect_name => psb_z_csput_a use psb_z_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -705,15 +705,15 @@ subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -725,13 +725,13 @@ subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_z_csput_a -subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_mat_mod, psb_protect_name => psb_z_csput_v use psb_z_base_mat_mod use psb_z_vect_mod, only : psb_z_vect_type use psb_i_vect_mod, only : psb_i_vect_type use psb_error_mod - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a type(psb_z_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: ia, ja @@ -744,19 +744,19 @@ subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -771,7 +771,7 @@ end subroutine psb_z_csput_v subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -794,7 +794,7 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -803,7 +803,7 @@ subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -818,7 +818,7 @@ end subroutine psb_z_csgetptn subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -842,7 +842,7 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -851,7 +851,7 @@ subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -868,7 +868,7 @@ end subroutine psb_z_csgetrow subroutine psb_z_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -893,31 +893,31 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -936,7 +936,7 @@ subroutine psb_z_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_z_base_mat_mod use psb_z_mat_mod, psb_protect_name => psb_z_tril - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -951,22 +951,22 @@ subroutine psb_z_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -975,7 +975,7 @@ subroutine psb_z_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -993,7 +993,7 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_z_base_mat_mod use psb_z_mat_mod, psb_protect_name => psb_z_triu - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -1009,24 +1009,24 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -1035,7 +1035,7 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1047,9 +1047,10 @@ subroutine psb_z_triu(a,u,info,diag,imin,imax,& end subroutine psb_z_triu + subroutine psb_z_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -1069,24 +1070,24 @@ subroutine psb_z_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1099,7 +1100,7 @@ end subroutine psb_z_csclip subroutine psb_z_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -1118,14 +1119,14 @@ subroutine psb_z_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -1133,8 +1134,8 @@ subroutine psb_z_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -1147,7 +1148,7 @@ end subroutine psb_z_csclip_ip subroutine psb_z_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -1166,7 +1167,7 @@ subroutine psb_z_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1174,7 +1175,7 @@ subroutine psb_z_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1190,7 +1191,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_cscnv - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1207,7 +1208,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1219,38 +1220,38 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_z_coo_sparse_mat :: altmp, stat=info) + allocate(psb_z_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_z_csc_sparse_mat :: altmp, stat=info) + allocate(psb_z_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -1268,7 +1269,7 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%set_asb() + call b%set_asb() call psb_erractionrestore(err_act) return @@ -1283,7 +1284,7 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_ip - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -1300,15 +1301,15 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -1318,29 +1319,29 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_z_csr_sparse_mat :: altmp, stat=info) + allocate(psb_z_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_z_coo_sparse_mat :: altmp, stat=info) + allocate(psb_z_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_z_csc_sparse_mat :: altmp, stat=info) + allocate(psb_z_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1359,7 +1360,7 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) call move_alloc(altmp,a%a) call a%trim() - call a%set_asb() + call a%set_asb() call psb_erractionrestore(err_act) return @@ -1376,7 +1377,7 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_base - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -1391,19 +1392,19 @@ subroutine psb_z_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -1425,7 +1426,7 @@ end subroutine psb_z_cscnv_base subroutine psb_z_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -1444,15 +1445,15 @@ subroutine psb_z_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -1461,8 +1462,8 @@ subroutine psb_z_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1485,7 +1486,7 @@ end subroutine psb_z_clip_d subroutine psb_z_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -1503,13 +1504,13 @@ subroutine psb_z_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -1520,8 +1521,8 @@ subroutine psb_z_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -1546,7 +1547,7 @@ subroutine psb_z_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_mv_from - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1564,7 +1565,7 @@ subroutine psb_z_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_from - implicit none + implicit none class(psb_zspmat_type), intent(out) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -1573,7 +1574,7 @@ subroutine psb_z_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -1582,8 +1583,8 @@ subroutine psb_z_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1599,11 +1600,11 @@ subroutine psb_z_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_mv_to - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -1614,7 +1615,7 @@ subroutine psb_z_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_to - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -1631,14 +1632,14 @@ subroutine psb_z_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_z_mold subroutine psb_zspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_zspmat_type_move - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1659,7 +1660,7 @@ subroutine psb_zspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_zspmat_clone - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1671,10 +1672,10 @@ subroutine psb_zspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1691,7 +1692,7 @@ subroutine psb_z_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_transp_1mat - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1700,7 +1701,7 @@ subroutine psb_z_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1724,7 +1725,7 @@ subroutine psb_z_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_transp_2mat - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b @@ -1734,18 +1735,18 @@ subroutine psb_z_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -1762,7 +1763,7 @@ subroutine psb_z_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_transc_1mat - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -1771,7 +1772,7 @@ subroutine psb_z_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -1795,7 +1796,7 @@ subroutine psb_z_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_z_transc_2mat - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b @@ -1805,18 +1806,18 @@ subroutine psb_z_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -1832,9 +1833,9 @@ end subroutine psb_z_transc_2mat subroutine psb_z_asb(a,mold) use psb_z_mat_mod, psb_protect_name => psb_z_asb use psb_error_mod - implicit none + implicit none - class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), optional, intent(in) :: mold class(psb_z_base_sparse_mat), allocatable :: tmp class(psb_z_base_sparse_mat), pointer :: mld @@ -1842,15 +1843,15 @@ subroutine psb_z_asb(a,mold) character(len=20) :: name='z_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -1861,7 +1862,7 @@ subroutine psb_z_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -1876,21 +1877,21 @@ end subroutine psb_z_asb subroutine psb_z_reinit(a,clear) use psb_z_mat_mod, psb_protect_name => psb_z_reinit use psb_error_mod - implicit none + implicit none - class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -1925,10 +1926,10 @@ end subroutine psb_z_reinit ! == =================================== -subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_z_mat_mod, psb_protect_name => psb_z_csmm - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1940,14 +1941,14 @@ subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1958,10 +1959,10 @@ subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) end subroutine psb_z_csmm -subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_z_mat_mod, psb_protect_name => psb_z_csmv - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1973,14 +1974,14 @@ subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x,beta,y,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x,beta,y,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -1990,11 +1991,11 @@ subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) end subroutine psb_z_csmv -subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) +subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) use psb_error_mod use psb_z_vect_mod use psb_z_mat_mod, psb_protect_name => psb_z_csmv_vect - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta type(psb_z_vect_type), intent(inout) :: x @@ -2007,25 +2008,25 @@ subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spmm(alpha,x%v,beta,y%v,info,trans) - if (info /= psb_success_) goto 9999 + call a%a%spmm(alpha,x%v,beta,y%v,info,trans) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2037,10 +2038,10 @@ end subroutine psb_z_csmv_vect -subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_z_mat_mod, psb_protect_name => psb_z_cssm - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -2053,14 +2054,14 @@ subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2072,10 +2073,10 @@ subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_z_cssm -subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_z_mat_mod, psb_protect_name => psb_z_cssv - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -2088,15 +2089,15 @@ subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) + call a%a%spsm(alpha,x,beta,y,info,trans,scale,d) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2108,11 +2109,11 @@ subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) end subroutine psb_z_cssv -subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) +subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) use psb_error_mod use psb_z_vect_mod use psb_z_mat_mod, psb_protect_name => psb_z_cssv_vect - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta type(psb_z_vect_type), intent(inout) :: x @@ -2126,33 +2127,33 @@ subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(x%v)) then + if (.not.allocated(x%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (.not.allocated(y%v)) then + if (.not.allocated(y%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - if (present(d)) then - if (.not.allocated(d%v)) then + if (present(d)) then + if (.not.allocated(d%v)) then info = psb_err_invalid_vect_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale,d%v) else - call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) + call a%a%spsm(alpha,x%v,beta,y%v,info,trans,scale) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -2167,7 +2168,7 @@ function psb_z_maxval(a) result(res) use psb_z_mat_mod, psb_protect_name => psb_z_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -2178,7 +2179,7 @@ function psb_z_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2198,7 +2199,7 @@ function psb_z_csnmi(a) result(res) use psb_z_mat_mod, psb_protect_name => psb_z_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -2208,7 +2209,7 @@ function psb_z_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2229,7 +2230,7 @@ function psb_z_csnm1(a) result(res) use psb_z_mat_mod, psb_protect_name => psb_z_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -2239,7 +2240,7 @@ function psb_z_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2260,7 +2261,7 @@ function psb_z_rowsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_z_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2271,7 +2272,7 @@ function psb_z_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2293,7 +2294,7 @@ function psb_z_arwsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_z_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2304,7 +2305,7 @@ function psb_z_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2327,7 +2328,7 @@ function psb_z_colsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_z_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2338,7 +2339,7 @@ function psb_z_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2361,7 +2362,7 @@ function psb_z_aclsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_z_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2372,7 +2373,7 @@ function psb_z_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2396,7 +2397,7 @@ function psb_z_get_diag(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_z_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2407,14 +2408,14 @@ function psb_z_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -2435,7 +2436,7 @@ subroutine psb_z_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_scal - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -2447,7 +2448,7 @@ subroutine psb_z_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2470,7 +2471,7 @@ subroutine psb_z_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_scals - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -2481,7 +2482,7 @@ subroutine psb_z_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2499,12 +2500,152 @@ subroutine psb_z_scals(d,a,info) end subroutine psb_z_scals +subroutine psb_z_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_scalplusidentity + implicit none + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_scalplusidentity + +subroutine psb_z_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_spaxpby + implicit none + complex(psb_dpk_), intent(in) :: alpha + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: beta + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_spaxpby + +function psb_z_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cmpval + implicit none + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_z_cmpval + +function psb_z_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cmpmat + implicit none + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_z_cmpmat + subroutine psb_z_mv_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_mv_from_lb - implicit none - + implicit none + class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2512,16 +2653,16 @@ subroutine psb_z_mv_from_lb(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_lfmt(b,info) - + end subroutine psb_z_mv_from_lb - + subroutine psb_z_cp_from_lb(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_from_lb - implicit none - + implicit none + class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -2536,30 +2677,30 @@ subroutine psb_z_mv_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_mv_to_lb - implicit none - + implicit none + class(psb_zspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_lfmt(b,info) call a%free() end if - + end subroutine psb_z_mv_to_lb subroutine psb_z_cp_to_lb(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_to_lb - implicit none + implicit none class(psb_zspmat_type), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -2572,7 +2713,7 @@ subroutine psb_z_mv_from_l(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_mv_from_l - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -2585,21 +2726,21 @@ subroutine psb_z_mv_from_l(a,b) call a%free() end if call b%free() - + end subroutine psb_z_mv_from_l - + subroutine psb_z_cp_from_l(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_from_l - implicit none + implicit none class(psb_zspmat_type), intent(out) :: a class(psb_lzspmat_type), intent(in) :: b integer(psb_ipk_) :: info - info = psb_success_ + info = psb_success_ if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_lfmt(b%a,info) @@ -2612,12 +2753,12 @@ subroutine psb_z_mv_to_l(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_mv_to_l - implicit none + implicit none class(psb_zspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_lz_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_lfmt(b%a,info) @@ -2625,26 +2766,26 @@ subroutine psb_z_mv_to_l(a,b) call b%free() end if call a%free() - + end subroutine psb_z_mv_to_l subroutine psb_z_cp_to_l(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_z_cp_to_l - implicit none - + implicit none + class(psb_zspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_lz_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_lfmt(b%a,info) else call b%free() end if - + end subroutine psb_z_cp_to_l @@ -2654,10 +2795,10 @@ end subroutine psb_z_cp_to_l ! -subroutine psb_lz_set_lnrows(m,a) +subroutine psb_lz_set_lnrows(m,a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_lnrows use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2665,7 +2806,7 @@ subroutine psb_lz_set_lnrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2683,10 +2824,10 @@ subroutine psb_lz_set_lnrows(m,a) end subroutine psb_lz_set_lnrows #if defined(IPK4) && defined(LPK8) -subroutine psb_lz_set_inrows(m,a) +subroutine psb_lz_set_inrows(m,a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_inrows use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: m integer(psb_ipk_) :: err_act, info @@ -2694,7 +2835,7 @@ subroutine psb_lz_set_inrows(m,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2712,10 +2853,10 @@ subroutine psb_lz_set_inrows(m,a) end subroutine psb_lz_set_inrows #endif -subroutine psb_lz_set_lncols(n,a) +subroutine psb_lz_set_lncols(n,a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_lncols use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2723,7 +2864,7 @@ subroutine psb_lz_set_lncols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2740,10 +2881,10 @@ subroutine psb_lz_set_lncols(n,a) end subroutine psb_lz_set_lncols #if defined(IPK4) && defined(LPK8) -subroutine psb_lz_set_incols(n,a) +subroutine psb_lz_set_incols(n,a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_incols use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2751,7 +2892,7 @@ subroutine psb_lz_set_incols(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2770,16 +2911,16 @@ end subroutine psb_lz_set_incols #endif ! -! Valid values for DUPL: -! psb_dupl_ovwrt_ -! psb_dupl_add_ -! psb_dupl_err_ +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ ! -subroutine psb_lz_set_dupl(n,a) +subroutine psb_lz_set_dupl(n,a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_dupl use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: n integer(psb_ipk_) :: err_act, info @@ -2787,7 +2928,7 @@ subroutine psb_lz_set_dupl(n,a) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2809,17 +2950,17 @@ end subroutine psb_lz_set_dupl ! Set the STATE of the internal matrix object ! -subroutine psb_lz_set_null(a) +subroutine psb_lz_set_null(a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_null use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2837,17 +2978,17 @@ subroutine psb_lz_set_null(a) end subroutine psb_lz_set_null -subroutine psb_lz_set_bld(a) +subroutine psb_lz_set_bld(a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_bld use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2866,17 +3007,17 @@ subroutine psb_lz_set_bld(a) end subroutine psb_lz_set_bld -subroutine psb_lz_set_upd(a) +subroutine psb_lz_set_upd(a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_upd use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2896,17 +3037,17 @@ subroutine psb_lz_set_upd(a) end subroutine psb_lz_set_upd -subroutine psb_lz_set_asb(a) +subroutine psb_lz_set_asb(a) use psb_z_mat_mod, psb_protect_name => psb_lz_set_asb use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='get_nzeros' logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2925,10 +3066,10 @@ subroutine psb_lz_set_asb(a) end subroutine psb_lz_set_asb -subroutine psb_lz_set_sorted(a,val) +subroutine psb_lz_set_sorted(a,val) use psb_z_mat_mod, psb_protect_name => psb_lz_set_sorted use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2936,7 +3077,7 @@ subroutine psb_lz_set_sorted(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2955,10 +3096,10 @@ subroutine psb_lz_set_sorted(a,val) end subroutine psb_lz_set_sorted -subroutine psb_lz_set_triangle(a,val) +subroutine psb_lz_set_triangle(a,val) use psb_z_mat_mod, psb_protect_name => psb_lz_set_triangle use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2966,7 +3107,7 @@ subroutine psb_lz_set_triangle(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -2984,10 +3125,10 @@ subroutine psb_lz_set_triangle(a,val) end subroutine psb_lz_set_triangle -subroutine psb_lz_set_symmetric(a,val) +subroutine psb_lz_set_symmetric(a,val) use psb_z_mat_mod, psb_protect_name => psb_lz_set_symmetric use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -2995,7 +3136,7 @@ subroutine psb_lz_set_symmetric(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3013,10 +3154,10 @@ subroutine psb_lz_set_symmetric(a,val) end subroutine psb_lz_set_symmetric -subroutine psb_lz_set_unit(a,val) +subroutine psb_lz_set_unit(a,val) use psb_z_mat_mod, psb_protect_name => psb_lz_set_unit use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3024,7 +3165,7 @@ subroutine psb_lz_set_unit(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3043,10 +3184,10 @@ subroutine psb_lz_set_unit(a,val) end subroutine psb_lz_set_unit -subroutine psb_lz_set_lower(a,val) +subroutine psb_lz_set_lower(a,val) use psb_z_mat_mod, psb_protect_name => psb_lz_set_lower use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3054,7 +3195,7 @@ subroutine psb_lz_set_lower(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3073,10 +3214,10 @@ subroutine psb_lz_set_lower(a,val) end subroutine psb_lz_set_lower -subroutine psb_lz_set_upper(a,val) +subroutine psb_lz_set_upper(a,val) use psb_z_mat_mod, psb_protect_name => psb_lz_set_upper use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: val integer(psb_ipk_) :: err_act, info @@ -3084,7 +3225,7 @@ subroutine psb_lz_set_upper(a,val) logical, parameter :: debug=.false. call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3114,16 +3255,16 @@ end subroutine psb_lz_set_upper ! ! ! -! == =================================== +! == =================================== subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) use psb_z_mat_mod, psb_protect_name => psb_lz_sparse_print use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: iout - class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3134,7 +3275,7 @@ subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3154,10 +3295,10 @@ end subroutine psb_lz_sparse_print subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) use psb_z_mat_mod, psb_protect_name => psb_lz_n_sparse_print use psb_error_mod - implicit none + implicit none - character(len=*), intent(in) :: fname - class(psb_lzspmat_type), intent(in) :: a + character(len=*), intent(in) :: fname + class(psb_lzspmat_type), intent(in) :: a integer(psb_lpk_), intent(in), optional :: iv(:) character(len=*), optional :: head integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) @@ -3169,24 +3310,24 @@ subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 - do + do inquire(unit=iout, opened=isopen) if (.not.isopen) exit iout = iout + 1 if (iout > 99) exit end do - if (iout > 99) then + if (iout > 99) then write(psb_err_unit,*) 'Error: could not find a free unit for I/O' return end if open(iout,file=fname,iostat=info) - if (info == psb_success_) then + if (info == psb_success_) then call a%a%print(iout,iv,head,ivr,ivc) close(iout) else @@ -3205,13 +3346,13 @@ end subroutine psb_lz_n_sparse_print subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) use psb_z_mat_mod, psb_protect_name => psb_lz_get_neigh use psb_error_mod - implicit none - class(psb_lzspmat_type), intent(in) :: a - integer(psb_lpk_), intent(in) :: idx - integer(psb_lpk_), intent(out) :: n + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n integer(psb_lpk_), allocatable, intent(out) :: neigh(:) integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), optional, intent(in) :: lev + integer(psb_lpk_), optional, intent(in) :: lev integer(psb_ipk_) :: err_act character(len=20) :: name='get_neigh' @@ -3219,7 +3360,7 @@ subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3240,17 +3381,17 @@ end subroutine psb_lz_get_neigh -subroutine psb_lz_csall(nr,nc,a,info,nz) +subroutine psb_lz_csall(nr,nc,a,info,nz) use psb_z_mat_mod, psb_protect_name => psb_lz_csall use psb_z_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_lpk_), intent(in) :: nr,nc integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='csall' logical, parameter :: debug=.false. @@ -3260,13 +3401,13 @@ subroutine psb_lz_csall(nr,nc,a,info,nz) info = psb_success_ allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 end if call a%a%allocate(nr,nc,nz) - call a%set_bld() + call a%set_bld() return @@ -3277,10 +3418,10 @@ subroutine psb_lz_csall(nr,nc,a,info,nz) end subroutine psb_lz_csall -subroutine psb_lz_reallocate_nz(nz,a) +subroutine psb_lz_reallocate_nz(nz,a) use psb_z_mat_mod, psb_protect_name => psb_lz_reallocate_nz use psb_error_mod - implicit none + implicit none integer(psb_lpk_), intent(in) :: nz class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -3288,7 +3429,7 @@ subroutine psb_lz_reallocate_nz(nz,a) logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3305,31 +3446,31 @@ subroutine psb_lz_reallocate_nz(nz,a) end subroutine psb_lz_reallocate_nz -subroutine psb_lz_free(a) +subroutine psb_lz_free(a) use psb_z_mat_mod, psb_protect_name => psb_lz_free use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%free() - deallocate(a%a) + deallocate(a%a) endif end subroutine psb_lz_free -subroutine psb_lz_trim(a) +subroutine psb_lz_trim(a) use psb_z_mat_mod, psb_protect_name => psb_lz_trim use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info character(len=20) :: name='trim' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3347,11 +3488,11 @@ end subroutine psb_lz_trim -subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_mat_mod, psb_protect_name => psb_lz_csput_a use psb_z_base_mat_mod use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -3363,15 +3504,15 @@ subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) - if (info /= psb_success_) goto 9999 + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3383,13 +3524,13 @@ subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) end subroutine psb_lz_csput_a -subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) +subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) use psb_z_mat_mod, psb_protect_name => psb_lz_csput_v use psb_z_base_mat_mod use psb_z_vect_mod, only : psb_z_vect_type use psb_l_vect_mod, only : psb_l_vect_type use psb_error_mod - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a type(psb_z_vect_type), intent(inout) :: val type(psb_l_vect_type), intent(inout) :: ia, ja @@ -3402,19 +3543,19 @@ subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.(a%is_bld().or.a%is_upd())) then + if (.not.(a%is_bld().or.a%is_upd())) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then - call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info) else info = psb_err_invalid_mat_state_ endif - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3429,7 +3570,7 @@ end subroutine psb_lz_csput_v subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -3452,7 +3593,7 @@ subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3461,7 +3602,7 @@ subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& call a%a%csget(imin,imax,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3476,7 +3617,7 @@ end subroutine psb_lz_csgetptn subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -3500,7 +3641,7 @@ subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3509,7 +3650,7 @@ subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& call a%a%csget(imin,imax,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3526,7 +3667,7 @@ end subroutine psb_lz_csgetrow subroutine psb_lz_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -3551,31 +3692,31 @@ subroutine psb_lz_csgetblk(imin,imax,a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(append)) then + if (present(append)) then append_ = append else append_ = .false. end if - allocate(acoo,stat=info) - if (append_.and.(info==psb_success_)) then + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then if (allocated(b%a)) & & call b%a%mv_to_coo(acoo,info) end if - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csget(imin,imax,acoo,info,& & jmin,jmax,iren,append,rscale,cscale) else info = psb_err_alloc_dealloc_ end if if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3594,7 +3735,7 @@ subroutine psb_lz_tril(a,l,info,diag,imin,imax,& use psb_const_mod use psb_z_base_mat_mod use psb_z_mat_mod, psb_protect_name => psb_lz_tril - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: l integer(psb_ipk_),intent(out) :: info @@ -3609,22 +3750,22 @@ subroutine psb_lz_tril(a,l,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(lcoo,stat=info) + allocate(lcoo,stat=info) call l%free() if (present(u)) then - if (info == psb_success_) allocate(ucoo,stat=info) + if (info == psb_success_) allocate(ucoo,stat=info) call u%free() if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,ucoo) if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%tril(lcoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3633,7 +3774,7 @@ subroutine psb_lz_tril(a,l,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3651,7 +3792,7 @@ subroutine psb_lz_triu(a,u,info,diag,imin,imax,& use psb_const_mod use psb_z_base_mat_mod use psb_z_mat_mod, psb_protect_name => psb_lz_triu - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: u integer(psb_ipk_),intent(out) :: info @@ -3667,24 +3808,24 @@ subroutine psb_lz_triu(a,u,info,diag,imin,imax,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(ucoo,stat=info) + allocate(ucoo,stat=info) call u%free() if (present(l)) then - if (info == psb_success_) allocate(lcoo,stat=info) + if (info == psb_success_) allocate(lcoo,stat=info) call l%free() if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,lcoo) if (info == psb_success_) call move_alloc(lcoo,l%a) if (info == psb_success_) call l%cscnv(info,mold=a%a) else - if (info == psb_success_) then + if (info == psb_success_) then call a%a%triu(ucoo,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) else @@ -3693,7 +3834,7 @@ subroutine psb_lz_triu(a,u,info,diag,imin,imax,& end if if (info == psb_success_) call move_alloc(ucoo,u%a) if (info == psb_success_) call u%cscnv(info,mold=a%a) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3708,7 +3849,7 @@ end subroutine psb_lz_triu subroutine psb_lz_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -3728,24 +3869,24 @@ subroutine psb_lz_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) call b%free() - if (info == psb_success_) then + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else info = psb_err_alloc_dealloc_ end if - + if (info == psb_success_) call move_alloc(acoo,b%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3758,7 +3899,7 @@ end subroutine psb_lz_csclip subroutine psb_lz_csclip_ip(a,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -3777,14 +3918,14 @@ subroutine psb_lz_csclip_ip(a,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) then + allocate(acoo,stat=info) + if (info == psb_success_) then call a%a%csclip(acoo,info,& & imin,imax,jmin,jmax,rscale,cscale) else @@ -3792,8 +3933,8 @@ subroutine psb_lz_csclip_ip(a,info,& end if if (info == psb_success_) call a%free() if (info == psb_success_) call move_alloc(acoo,a%a) - if (info /= psb_success_) goto 9999 - + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return @@ -3806,7 +3947,7 @@ end subroutine psb_lz_csclip_ip subroutine psb_lz_b_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -3825,7 +3966,7 @@ subroutine psb_lz_b_csclip(a,b,info,& info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3833,7 +3974,7 @@ subroutine psb_lz_b_csclip(a,b,info,& call a%a%csclip(b,info,& & imin,imax,jmin,jmax,rscale,cscale) - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -3852,7 +3993,7 @@ subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -3869,7 +4010,7 @@ subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -3881,38 +4022,38 @@ subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) + allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) + allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) + allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if - - if (present(dupl)) then + + if (present(dupl)) then call altmp%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then ! Does this make sense at all?? Who knows.. call altmp%set_dupl(psb_dupl_def_) end if @@ -3930,7 +4071,7 @@ subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) call move_alloc(altmp,b%a) call b%trim() - call b%asb() + call b%asb() call psb_erractionrestore(err_act) return @@ -3947,7 +4088,7 @@ subroutine psb_lz_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv_ip - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_), intent(out) :: info @@ -3964,15 +4105,15 @@ subroutine psb_lz_cscnv_ip(a,info,type,mold,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (present(dupl)) then + if (present(dupl)) then call a%set_dupl(dupl) - else if (a%is_bld()) then + else if (a%is_bld()) then call a%set_dupl(psb_dupl_def_) end if @@ -3982,29 +4123,29 @@ subroutine psb_lz_cscnv_ip(a,info,type,mold,dupl) goto 9999 end if - if (present(mold)) then + if (present(mold)) then - allocate(altmp, mold=mold,stat=info) + allocate(altmp, mold=mold,stat=info) - else if (present(type)) then + else if (present(type)) then select case (psb_toupper(type)) case ('CSR') - allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) + allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) case ('COO') - allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) + allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) case ('CSC') - allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) + allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) case default - info = psb_err_format_unknown_ + info = psb_err_format_unknown_ call psb_errpush(info,name,a_err=type) goto 9999 end select else - allocate(altmp, mold=psb_get_mat_default(a),stat=info) + allocate(altmp, mold=psb_get_mat_default(a),stat=info) end if - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4022,7 +4163,7 @@ subroutine psb_lz_cscnv_ip(a,info,type,mold,dupl) end if call move_alloc(altmp,a%a) - call a%set_asb() + call a%set_asb() call a%trim() call psb_erractionrestore(err_act) return @@ -4040,7 +4181,7 @@ subroutine psb_lz_cscnv_base(a,b,info,dupl) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv_base - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lz_base_sparse_mat), intent(out) :: b integer(psb_ipk_), intent(out) :: info @@ -4055,19 +4196,19 @@ subroutine psb_lz_cscnv_base(a,b,info,dupl) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%cp_to_coo(altmp,info ) - if ((info == psb_success_).and.present(dupl)) then + if ((info == psb_success_).and.present(dupl)) then call altmp%set_dupl(dupl) end if call altmp%fix(info) if (info == psb_success_) call altmp%trim() - if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call altmp%set_asb() if (info == psb_success_) call b%mv_from_coo(altmp,info) if (info /= psb_success_) then @@ -4089,7 +4230,7 @@ end subroutine psb_lz_cscnv_base subroutine psb_lz_clip_d(a,b,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -4108,15 +4249,15 @@ subroutine psb_lz_clip_d(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%cp_to_coo(acoo,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 @@ -4125,8 +4266,8 @@ subroutine psb_lz_clip_d(a,b,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4149,7 +4290,7 @@ end subroutine psb_lz_clip_d subroutine psb_lz_clip_d_ip(a,info) - ! Output is always in COO format + ! Output is always in COO format use psb_error_mod use psb_const_mod use psb_z_base_mat_mod @@ -4167,13 +4308,13 @@ subroutine psb_lz_clip_d_ip(a,info) info = psb_success_ call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - allocate(acoo,stat=info) + allocate(acoo,stat=info) if (info == psb_success_) call a%a%mv_to_coo(acoo,info) if (info /= psb_success_) then info = psb_err_alloc_dealloc_ @@ -4184,8 +4325,8 @@ subroutine psb_lz_clip_d_ip(a,info) nz = acoo%get_nzeros() j = 0 do i=1, nz - if (acoo%ia(i) /= acoo%ja(i)) then - j = j + 1 + if (acoo%ia(i) /= acoo%ja(i)) then + j = j + 1 acoo%ia(j) = acoo%ia(i) acoo%ja(j) = acoo%ja(i) acoo%val(j) = acoo%val(i) @@ -4210,7 +4351,7 @@ subroutine psb_lz_mv_from(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4228,7 +4369,7 @@ subroutine psb_lz_cp_from(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from - implicit none + implicit none class(psb_lzspmat_type), intent(out) :: a class(psb_lz_base_sparse_mat), intent(in) :: b integer(psb_ipk_) :: err_act, info @@ -4237,7 +4378,7 @@ subroutine psb_lz_cp_from(a,b) call psb_erractionsave(err_act) info = psb_success_ - + call a%free() ! ! Note: it is tempting to use SOURCE allocation below; @@ -4246,8 +4387,8 @@ subroutine psb_lz_cp_from(a,b) ! allocate(a%a,mold=b,stat=info) if (info /= psb_success_) info = psb_err_alloc_dealloc_ - if (info == psb_success_) call a%a%cp_from_fmt(b, info) - if (info /= psb_success_) goto 9999 + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4263,11 +4404,11 @@ subroutine psb_lz_mv_to(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + call b%mv_from_fmt(a%a,info) return @@ -4278,7 +4419,7 @@ subroutine psb_lz_cp_to(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lz_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4295,14 +4436,14 @@ subroutine psb_lz_mold(a,b) integer(psb_ipk_) :: info allocate(b,mold=a%a, stat=info) - + end subroutine psb_lz_mold subroutine psb_lzspmat_type_move(a,b,info) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lzspmat_type_move - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4323,7 +4464,7 @@ subroutine psb_lzspmat_clone(a,b,info) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lzspmat_clone - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a class(psb_lzspmat_type), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -4335,10 +4476,10 @@ subroutine psb_lzspmat_clone(a,b,info) call psb_erractionsave(err_act) info = psb_success_ call b%free() - if (allocated(a%a)) then + if (allocated(a%a)) then call a%a%clone(b%a,info) end if - if (info /= psb_success_) goto 9999 + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return @@ -4355,7 +4496,7 @@ subroutine psb_lz_transp_1mat(a) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_transp_1mat - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4364,7 +4505,7 @@ subroutine psb_lz_transp_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4388,7 +4529,7 @@ subroutine psb_lz_transp_2mat(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_transp_2mat - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: b @@ -4398,18 +4539,18 @@ subroutine psb_lz_transp_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transp(b%a) + call a%a%transp(b%a) call psb_erractionrestore(err_act) return @@ -4426,7 +4567,7 @@ subroutine psb_lz_transc_1mat(a) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_transc_1mat - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a integer(psb_ipk_) :: err_act, info @@ -4435,7 +4576,7 @@ subroutine psb_lz_transc_1mat(a) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4459,7 +4600,7 @@ subroutine psb_lz_transc_2mat(a,b) use psb_error_mod use psb_string_mod use psb_z_mat_mod, psb_protect_name => psb_lz_transc_2mat - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_lzspmat_type), intent(inout) :: b @@ -4469,18 +4610,18 @@ subroutine psb_lz_transc_2mat(a,b) call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call b%free() allocate(b%a,mold=a%a,stat=info) - if (info /= psb_success_) then + if (info /= psb_success_) then info = psb_err_alloc_dealloc_ goto 9999 end if - call a%a%transc(b%a) + call a%a%transc(b%a) call psb_erractionrestore(err_act) return @@ -4496,9 +4637,9 @@ end subroutine psb_lz_transc_2mat subroutine psb_lz_asb(a,mold) use psb_z_mat_mod, psb_protect_name => psb_lz_asb use psb_error_mod - implicit none + implicit none - class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: a class(psb_lz_base_sparse_mat), optional, intent(in) :: mold class(psb_lz_base_sparse_mat), allocatable :: tmp class(psb_lz_base_sparse_mat), pointer :: mld @@ -4506,15 +4647,15 @@ subroutine psb_lz_asb(a,mold) character(len=20) :: name='lz_asb' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif call a%a%asb() - if (present(mold)) then - if (.not.same_type_as(a%a,mold)) then + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then allocate(tmp,mold=mold) call tmp%mv_from_fmt(a%a,info) call a%a%free() @@ -4525,7 +4666,7 @@ subroutine psb_lz_asb(a,mold) if (.not.same_type_as(a%a,mld)) & & call a%cscnv(info) end if - + call psb_erractionrestore(err_act) return @@ -4540,21 +4681,21 @@ end subroutine psb_lz_asb subroutine psb_lz_reinit(a,clear) use psb_z_mat_mod, psb_protect_name => psb_lz_reinit use psb_error_mod - implicit none + implicit none - class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: a logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' call psb_erractionsave(err_act) - if (a%is_null()) then + if (a%is_null()) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif - if (a%a%has_update()) then + if (a%a%has_update()) then call a%a%reinit(clear) else info = psb_err_missing_override_method_ @@ -4579,7 +4720,7 @@ function psb_lz_get_diag(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_lz_get_diag use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4590,14 +4731,14 @@ function psb_lz_get_diag(a,info) result(d) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 endif allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) - if (info /= 0) then - info = psb_err_alloc_dealloc_ + if (info /= 0) then + info = psb_err_alloc_dealloc_ call psb_errpush(info,name) goto 9999 end if @@ -4618,7 +4759,7 @@ subroutine psb_lz_scal(d,a,info,side) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_scal - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4630,7 +4771,7 @@ subroutine psb_lz_scal(d,a,info,side) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4653,7 +4794,7 @@ subroutine psb_lz_scals(d,a,info) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_scals - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -4664,7 +4805,7 @@ subroutine psb_lz_scals(d,a,info) info = psb_success_ call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4682,11 +4823,151 @@ subroutine psb_lz_scals(d,a,info) end subroutine psb_lz_scals +subroutine psb_lz_scalplusidentity(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_scalplusidentity + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scalplusidentity' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scalpid(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_scalplusidentity + +subroutine psb_lz_spaxpby(alpha,a,beta,b,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_spaxpby + implicit none + complex(psb_dpk_), intent(in) :: alpha + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: beta + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='spaxby' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%spaxpby(alpha,beta,b%a,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_spaxpby + +function psb_lz_cmpval(a,val,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cmpval + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpval' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(val,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_cmpval + +function psb_lz_cmpmat(a,b,tol,info) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cmpmat + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + real(psb_dpk_), intent(in) :: tol + logical :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='cmpmat' + logical, parameter :: debug=.false. + + res = .false. + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spcmp(b%a,tol,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_cmpmat + function psb_lz_maxval(a) result(res) use psb_z_mat_mod, psb_protect_name => psb_lz_maxval use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -4697,7 +4978,7 @@ function psb_lz_maxval(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4717,7 +4998,7 @@ function psb_lz_csnmi(a) result(res) use psb_z_mat_mod, psb_protect_name => psb_lz_csnmi use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -4727,7 +5008,7 @@ function psb_lz_csnmi(a) result(res) info = psb_success_ call psb_get_erraction(err_act) - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4747,7 +5028,7 @@ function psb_lz_csnm1(a) result(res) use psb_z_mat_mod, psb_protect_name => psb_lz_csnm1 use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_) :: res @@ -4757,7 +5038,7 @@ function psb_lz_csnm1(a) result(res) call psb_get_erraction(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4778,7 +5059,7 @@ function psb_lz_rowsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_lz_rowsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4789,7 +5070,7 @@ function psb_lz_rowsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4811,7 +5092,7 @@ function psb_lz_arwsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_lz_arwsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4822,7 +5103,7 @@ function psb_lz_arwsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4845,7 +5126,7 @@ function psb_lz_colsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_lz_colsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a complex(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4856,7 +5137,7 @@ function psb_lz_colsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4879,7 +5160,7 @@ function psb_lz_aclsum(a,info) result(d) use psb_z_mat_mod, psb_protect_name => psb_lz_aclsum use psb_error_mod use psb_const_mod - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a real(psb_dpk_), allocatable :: d(:) integer(psb_ipk_), intent(out) :: info @@ -4890,7 +5171,7 @@ function psb_lz_aclsum(a,info) result(d) call psb_erractionsave(err_act) info = psb_success_ - if (.not.allocated(a%a)) then + if (.not.allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info,name) goto 9999 @@ -4913,8 +5194,8 @@ subroutine psb_lz_mv_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from_ib - implicit none - + implicit none + class(psb_lzspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4922,15 +5203,15 @@ subroutine psb_lz_mv_from_ib(a,b) info = psb_success_ if (.not.allocated(a%a)) allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) if (info == psb_success_) call a%a%mv_from_ifmt(b,info) - + end subroutine psb_lz_mv_from_ib - + subroutine psb_lz_cp_from_ib(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from_ib - implicit none - + implicit none + class(psb_lzspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info @@ -4945,30 +5226,30 @@ subroutine psb_lz_mv_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to_ib - implicit none - + implicit none + class(psb_lzspmat_type), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else call a%a%mv_to_ifmt(b,info) call a%free() end if - + end subroutine psb_lz_mv_to_ib subroutine psb_lz_cp_to_ib(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to_ib - implicit none + implicit none class(psb_lzspmat_type), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_) :: info - + if (.not.allocated(a%a)) then call b%free() else @@ -4981,7 +5262,7 @@ subroutine psb_lz_mv_from_i(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from_i - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_) :: info @@ -4993,20 +5274,20 @@ subroutine psb_lz_mv_from_i(a,b) call a%free() end if call b%free() - + end subroutine psb_lz_mv_from_i - + subroutine psb_lz_cp_from_i(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from_i - implicit none + implicit none class(psb_lzspmat_type), intent(out) :: a class(psb_zspmat_type), intent(in) :: b integer(psb_ipk_) :: info - + if (allocated(b%a)) then if (.not.allocated(a%a)) allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) call a%a%cp_from_ifmt(b%a,info) @@ -5019,12 +5300,12 @@ subroutine psb_lz_mv_to_i(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to_i - implicit none + implicit none class(psb_lzspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_z_csr_sparse_mat :: b%a, stat=info) call a%a%mv_to_ifmt(b%a,info) @@ -5032,28 +5313,24 @@ subroutine psb_lz_mv_to_i(a,b) call b%free() end if call a%free() - + end subroutine psb_lz_mv_to_i subroutine psb_lz_cp_to_i(a,b) use psb_error_mod use psb_const_mod use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to_i - implicit none - + implicit none + class(psb_lzspmat_type), intent(in) :: a class(psb_zspmat_type), intent(inout) :: b integer(psb_ipk_) :: info - + if (allocated(a%a)) then if (.not.allocated(b%a)) allocate(psb_z_csr_sparse_mat :: b%a, stat=info) call a%a%cp_to_ifmt(b%a,info) else call b%free() end if - + end subroutine psb_lz_cp_to_i - - - - diff --git a/base/serial/psi_c_serial_impl.f90 b/base/serial/psi_c_serial_impl.f90 index 77841b762..2120683da 100644 --- a/base/serial/psi_c_serial_impl.f90 +++ b/base/serial/psi_c_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_caxpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n complex(psb_spk_), intent (in) :: x(:,:) complex(psb_spk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_caxpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call caxpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_caxpby(m,n,alpha, x, beta, y, info) end subroutine psi_caxpby subroutine psi_caxpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_spk_), intent (in) :: x(:) complex(psb_spk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_caxpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call caxpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_caxpbyv(m,alpha, x, beta, y, info) end subroutine psi_caxpbyv +subroutine psi_caxpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_spk_), intent (in) :: x(:) + complex(psb_spk_), intent (in) :: y(:) + complex(psb_spk_), intent (inout) :: z(:) + complex(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call caxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_caxpbyv2 subroutine psi_cgthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_cgthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == czero) then - if (alpha == czero) then + if (beta == czero) then + if (alpha == czero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_cgthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -cone) then + else if (alpha == -cone) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_cgthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == cone) then + else + if (beta == cone) then ! Do nothing - else if (beta == -cone) then - y(1:n*k) = -y(1:n*k) + else if (beta == -cone) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == czero) then + if (alpha == czero) then ! do nothing - else if (alpha == cone) then + else if (alpha == cone) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_cgthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_cgthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == czero) then - if (alpha == czero) then + if (beta == czero) then + if (alpha == czero) then do i=1,n y(i) = czero end do - else if (alpha == cone) then + else if (alpha == cone) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -cone) then + else if (alpha == -cone) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == cone) then + else + if (beta == cone) then ! Do nothing - else if (beta == -cone) then - y(1:n) = -y(1:n) + else if (beta == -cone) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == czero) then + if (alpha == czero) then ! do nothing - else if (alpha == cone) then + else if (alpha == cone) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -cone) then + else if (alpha == -cone) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_cgthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_cgthzv(n,idx,x,y) end subroutine psi_cgthzv subroutine psi_csctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_csctmm(n,k,idx,x,beta,y) end subroutine psi_csctmm subroutine psi_csctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_csctv subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info complex(psb_spk_) X(lldx,*), Y(lldy,*) complex(psb_spk_) alpha, beta @@ -447,19 +508,19 @@ subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.czero) then - if (beta.eq.czero) then - do j=1, n - do i=1,m + if (alpha.eq.czero) then + if (beta.eq.czero) then + do j=1, n + do i=1,m y(i,j) = czero enddo enddo else if (beta.eq.cone) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-cone) then - do j=1,n - do i=1,m + else if (beta.eq.-cone) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.cone) then - if (beta.eq.czero) then - do j=1,n - do i=1,m + if (beta.eq.czero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.cone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-cone) then - do j=1,n - do i=1,m + else if (beta.eq.-cone) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-cone) then + else if (alpha.eq.-cone) then - if (beta.eq.czero) then - do j=1,n - do i=1,m + if (beta.eq.czero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.cone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-cone) then - do j=1,n - do i=1,m + else if (beta.eq.-cone) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.czero) then - do j=1,n - do i=1,m + if (beta.eq.czero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.cone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-cone) then - do j=1,n - do i=1,m + else if (beta.eq.-cone) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine caxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine caxpby + +subroutine caxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + complex(psb_spk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + complex(psb_spk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='caxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.czero) then + if (beta.eq.czero) then + do j=1, n + do i=1,m + Z(i,j) = czero + enddo + enddo + else if (beta.eq.cone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.cone) then + + if (beta.eq.czero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.cone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-cone) then + + if (beta.eq.czero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.cone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.czero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.cone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-cone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine caxpbyv2 diff --git a/base/serial/psi_d_serial_impl.f90 b/base/serial/psi_d_serial_impl.f90 index 0e1904f1e..0d80f459d 100644 --- a/base/serial/psi_d_serial_impl.f90 +++ b/base/serial/psi_d_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_daxpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n real(psb_dpk_), intent (in) :: x(:,:) real(psb_dpk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_daxpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call daxpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_daxpby(m,n,alpha, x, beta, y, info) end subroutine psi_daxpby subroutine psi_daxpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_dpk_), intent (in) :: x(:) real(psb_dpk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_daxpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call daxpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_daxpbyv(m,alpha, x, beta, y, info) end subroutine psi_daxpbyv +subroutine psi_daxpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_dpk_), intent (in) :: x(:) + real(psb_dpk_), intent (in) :: y(:) + real(psb_dpk_), intent (inout) :: z(:) + real(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call daxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_daxpbyv2 subroutine psi_dgthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_dgthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == dzero) then - if (alpha == dzero) then + if (beta == dzero) then + if (alpha == dzero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_dgthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -done) then + else if (alpha == -done) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_dgthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == done) then + else + if (beta == done) then ! Do nothing - else if (beta == -done) then - y(1:n*k) = -y(1:n*k) + else if (beta == -done) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == dzero) then + if (alpha == dzero) then ! do nothing - else if (alpha == done) then + else if (alpha == done) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_dgthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_dgthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == dzero) then - if (alpha == dzero) then + if (beta == dzero) then + if (alpha == dzero) then do i=1,n y(i) = dzero end do - else if (alpha == done) then + else if (alpha == done) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -done) then + else if (alpha == -done) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == done) then + else + if (beta == done) then ! Do nothing - else if (beta == -done) then - y(1:n) = -y(1:n) + else if (beta == -done) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == dzero) then + if (alpha == dzero) then ! do nothing - else if (alpha == done) then + else if (alpha == done) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -done) then + else if (alpha == -done) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_dgthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_dgthzv(n,idx,x,y) end subroutine psi_dgthzv subroutine psi_dsctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_dsctmm(n,k,idx,x,beta,y) end subroutine psi_dsctmm subroutine psi_dsctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_dsctv subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info real(psb_dpk_) X(lldx,*), Y(lldy,*) real(psb_dpk_) alpha, beta @@ -447,19 +508,19 @@ subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.dzero) then - if (beta.eq.dzero) then - do j=1, n - do i=1,m + if (alpha.eq.dzero) then + if (beta.eq.dzero) then + do j=1, n + do i=1,m y(i,j) = dzero enddo enddo else if (beta.eq.done) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-done) then - do j=1,n - do i=1,m + else if (beta.eq.-done) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.done) then - if (beta.eq.dzero) then - do j=1,n - do i=1,m + if (beta.eq.dzero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.done) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-done) then - do j=1,n - do i=1,m + else if (beta.eq.-done) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-done) then + else if (alpha.eq.-done) then - if (beta.eq.dzero) then - do j=1,n - do i=1,m + if (beta.eq.dzero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.done) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-done) then - do j=1,n - do i=1,m + else if (beta.eq.-done) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.dzero) then - do j=1,n - do i=1,m + if (beta.eq.dzero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.done) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-done) then - do j=1,n - do i=1,m + else if (beta.eq.-done) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine daxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine daxpby + +subroutine daxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + real(psb_dpk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + real(psb_dpk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='daxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.dzero) then + if (beta.eq.dzero) then + do j=1, n + do i=1,m + Z(i,j) = dzero + enddo + enddo + else if (beta.eq.done) then + ! + ! Do nothing! + ! + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.done) then + + if (beta.eq.dzero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.done) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-done) then + + if (beta.eq.dzero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.done) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.dzero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.done) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-done) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine daxpbyv2 diff --git a/base/serial/psi_e_serial_impl.f90 b/base/serial/psi_e_serial_impl.f90 index 9f1986511..0595d87e3 100644 --- a/base/serial/psi_e_serial_impl.f90 +++ b/base/serial/psi_e_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n integer(psb_epk_), intent (in) :: x(:,:) integer(psb_epk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call eaxpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) end subroutine psi_eaxpby subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m integer(psb_epk_), intent (in) :: x(:) integer(psb_epk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call eaxpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) end subroutine psi_eaxpbyv +subroutine psi_eaxpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_epk_), intent (in) :: x(:) + integer(psb_epk_), intent (in) :: y(:) + integer(psb_epk_), intent (inout) :: z(:) + integer(psb_epk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call eaxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_eaxpbyv2 subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == ezero) then - if (alpha == ezero) then + if (beta == ezero) then + if (alpha == ezero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -eone) then + else if (alpha == -eone) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == eone) then + else + if (beta == eone) then ! Do nothing - else if (beta == -eone) then - y(1:n*k) = -y(1:n*k) + else if (beta == -eone) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == ezero) then + if (alpha == ezero) then ! do nothing - else if (alpha == eone) then + else if (alpha == eone) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_egthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == ezero) then - if (alpha == ezero) then + if (beta == ezero) then + if (alpha == ezero) then do i=1,n y(i) = ezero end do - else if (alpha == eone) then + else if (alpha == eone) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -eone) then + else if (alpha == -eone) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == eone) then + else + if (beta == eone) then ! Do nothing - else if (beta == -eone) then - y(1:n) = -y(1:n) + else if (beta == -eone) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == ezero) then + if (alpha == ezero) then ! do nothing - else if (alpha == eone) then + else if (alpha == eone) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -eone) then + else if (alpha == -eone) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_egthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_egthzv(n,idx,x,y) end subroutine psi_egthzv subroutine psi_esctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_esctmm(n,k,idx,x,beta,y) end subroutine psi_esctmm subroutine psi_esctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_esctv subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info integer(psb_epk_) X(lldx,*), Y(lldy,*) integer(psb_epk_) alpha, beta @@ -447,19 +508,19 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.ezero) then - if (beta.eq.ezero) then - do j=1, n - do i=1,m + if (alpha.eq.ezero) then + if (beta.eq.ezero) then + do j=1, n + do i=1,m y(i,j) = ezero enddo enddo else if (beta.eq.eone) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-eone) then - do j=1,n - do i=1,m + else if (beta.eq.-eone) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.eone) then - if (beta.eq.ezero) then - do j=1,n - do i=1,m + if (beta.eq.ezero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.eone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-eone) then - do j=1,n - do i=1,m + else if (beta.eq.-eone) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-eone) then + else if (alpha.eq.-eone) then - if (beta.eq.ezero) then - do j=1,n - do i=1,m + if (beta.eq.ezero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.eone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-eone) then - do j=1,n - do i=1,m + else if (beta.eq.-eone) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.ezero) then - do j=1,n - do i=1,m + if (beta.eq.ezero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.eone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-eone) then - do j=1,n - do i=1,m + else if (beta.eq.-eone) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine eaxpby + +subroutine eaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + integer(psb_epk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + integer(psb_epk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='eaxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.ezero) then + if (beta.eq.ezero) then + do j=1, n + do i=1,m + Z(i,j) = ezero + enddo + enddo + else if (beta.eq.eone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-eone) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.eone) then + + if (beta.eq.ezero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.eone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-eone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-eone) then + + if (beta.eq.ezero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.eone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-eone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.ezero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.eone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-eone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine eaxpbyv2 diff --git a/base/serial/psi_i2_serial_impl.f90 b/base/serial/psi_i2_serial_impl.f90 index 30be1ddd9..59d579f2e 100644 --- a/base/serial/psi_i2_serial_impl.f90 +++ b/base/serial/psi_i2_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n integer(psb_i2pk_), intent (in) :: x(:,:) integer(psb_i2pk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call i2axpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) end subroutine psi_i2axpby subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m integer(psb_i2pk_), intent (in) :: x(:) integer(psb_i2pk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call i2axpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_i2axpbyv(m,alpha, x, beta, y, info) end subroutine psi_i2axpbyv +subroutine psi_i2axpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_i2pk_), intent (in) :: x(:) + integer(psb_i2pk_), intent (in) :: y(:) + integer(psb_i2pk_), intent (inout) :: z(:) + integer(psb_i2pk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call i2axpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_i2axpbyv2 subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == i2zero) then - if (alpha == i2zero) then + if (beta == i2zero) then + if (alpha == i2zero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -i2one) then + else if (alpha == -i2one) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == i2one) then + else + if (beta == i2one) then ! Do nothing - else if (beta == -i2one) then - y(1:n*k) = -y(1:n*k) + else if (beta == -i2one) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == i2zero) then + if (alpha == i2zero) then ! do nothing - else if (alpha == i2one) then + else if (alpha == i2one) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_i2gthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_i2gthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == i2zero) then - if (alpha == i2zero) then + if (beta == i2zero) then + if (alpha == i2zero) then do i=1,n y(i) = i2zero end do - else if (alpha == i2one) then + else if (alpha == i2one) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -i2one) then + else if (alpha == -i2one) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == i2one) then + else + if (beta == i2one) then ! Do nothing - else if (beta == -i2one) then - y(1:n) = -y(1:n) + else if (beta == -i2one) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == i2zero) then + if (alpha == i2zero) then ! do nothing - else if (alpha == i2one) then + else if (alpha == i2one) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -i2one) then + else if (alpha == -i2one) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_i2gthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_i2gthzv(n,idx,x,y) end subroutine psi_i2gthzv subroutine psi_i2sctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_i2sctmm(n,k,idx,x,beta,y) end subroutine psi_i2sctmm subroutine psi_i2sctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_i2sctv subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info integer(psb_i2pk_) X(lldx,*), Y(lldy,*) integer(psb_i2pk_) alpha, beta @@ -447,19 +508,19 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.i2zero) then - if (beta.eq.i2zero) then - do j=1, n - do i=1,m + if (alpha.eq.i2zero) then + if (beta.eq.i2zero) then + do j=1, n + do i=1,m y(i,j) = i2zero enddo enddo else if (beta.eq.i2one) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-i2one) then - do j=1,n - do i=1,m + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.i2one) then - if (beta.eq.i2zero) then - do j=1,n - do i=1,m + if (beta.eq.i2zero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.i2one) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-i2one) then - do j=1,n - do i=1,m + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-i2one) then + else if (alpha.eq.-i2one) then - if (beta.eq.i2zero) then - do j=1,n - do i=1,m + if (beta.eq.i2zero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.i2one) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-i2one) then - do j=1,n - do i=1,m + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.i2zero) then - do j=1,n - do i=1,m + if (beta.eq.i2zero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.i2one) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-i2one) then - do j=1,n - do i=1,m + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine i2axpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine i2axpby + +subroutine i2axpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + integer(psb_i2pk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + integer(psb_i2pk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='i2axpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.i2zero) then + if (beta.eq.i2zero) then + do j=1, n + do i=1,m + Z(i,j) = i2zero + enddo + enddo + else if (beta.eq.i2one) then + ! + ! Do nothing! + ! + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.i2one) then + + if (beta.eq.i2zero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.i2one) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-i2one) then + + if (beta.eq.i2zero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.i2one) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.i2zero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.i2one) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-i2one) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine i2axpbyv2 diff --git a/base/serial/psi_m_serial_impl.f90 b/base/serial/psi_m_serial_impl.f90 index a885f2bd6..cc8b9f4f1 100644 --- a/base/serial/psi_m_serial_impl.f90 +++ b/base/serial/psi_m_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_maxpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n integer(psb_mpk_), intent (in) :: x(:,:) integer(psb_mpk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_maxpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call maxpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_maxpby(m,n,alpha, x, beta, y, info) end subroutine psi_maxpby subroutine psi_maxpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m integer(psb_mpk_), intent (in) :: x(:) integer(psb_mpk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_maxpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call maxpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_maxpbyv(m,alpha, x, beta, y, info) end subroutine psi_maxpbyv +subroutine psi_maxpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_mpk_), intent (in) :: x(:) + integer(psb_mpk_), intent (in) :: y(:) + integer(psb_mpk_), intent (inout) :: z(:) + integer(psb_mpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call maxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_maxpbyv2 subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == mzero) then - if (alpha == mzero) then + if (beta == mzero) then + if (alpha == mzero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -mone) then + else if (alpha == -mone) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == mone) then + else + if (beta == mone) then ! Do nothing - else if (beta == -mone) then - y(1:n*k) = -y(1:n*k) + else if (beta == -mone) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == mzero) then + if (alpha == mzero) then ! do nothing - else if (alpha == mone) then + else if (alpha == mone) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_mgthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == mzero) then - if (alpha == mzero) then + if (beta == mzero) then + if (alpha == mzero) then do i=1,n y(i) = mzero end do - else if (alpha == mone) then + else if (alpha == mone) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -mone) then + else if (alpha == -mone) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == mone) then + else + if (beta == mone) then ! Do nothing - else if (beta == -mone) then - y(1:n) = -y(1:n) + else if (beta == -mone) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == mzero) then + if (alpha == mzero) then ! do nothing - else if (alpha == mone) then + else if (alpha == mone) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -mone) then + else if (alpha == -mone) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_mgthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_mgthzv(n,idx,x,y) end subroutine psi_mgthzv subroutine psi_msctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_msctmm(n,k,idx,x,beta,y) end subroutine psi_msctmm subroutine psi_msctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_msctv subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info integer(psb_mpk_) X(lldx,*), Y(lldy,*) integer(psb_mpk_) alpha, beta @@ -447,19 +508,19 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.mzero) then - if (beta.eq.mzero) then - do j=1, n - do i=1,m + if (alpha.eq.mzero) then + if (beta.eq.mzero) then + do j=1, n + do i=1,m y(i,j) = mzero enddo enddo else if (beta.eq.mone) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-mone) then - do j=1,n - do i=1,m + else if (beta.eq.-mone) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.mone) then - if (beta.eq.mzero) then - do j=1,n - do i=1,m + if (beta.eq.mzero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.mone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-mone) then - do j=1,n - do i=1,m + else if (beta.eq.-mone) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-mone) then + else if (alpha.eq.-mone) then - if (beta.eq.mzero) then - do j=1,n - do i=1,m + if (beta.eq.mzero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.mone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-mone) then - do j=1,n - do i=1,m + else if (beta.eq.-mone) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.mzero) then - do j=1,n - do i=1,m + if (beta.eq.mzero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.mone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-mone) then - do j=1,n - do i=1,m + else if (beta.eq.-mone) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine maxpby + +subroutine maxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + integer(psb_mpk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + integer(psb_mpk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='maxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.mzero) then + if (beta.eq.mzero) then + do j=1, n + do i=1,m + Z(i,j) = mzero + enddo + enddo + else if (beta.eq.mone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.mone) then + + if (beta.eq.mzero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.mone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-mone) then + + if (beta.eq.mzero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.mone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.mzero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.mone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine maxpbyv2 diff --git a/base/serial/psi_s_serial_impl.f90 b/base/serial/psi_s_serial_impl.f90 index f9b837279..dfe2559be 100644 --- a/base/serial/psi_s_serial_impl.f90 +++ b/base/serial/psi_s_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_saxpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n real(psb_spk_), intent (in) :: x(:,:) real(psb_spk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_saxpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call saxpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_saxpby(m,n,alpha, x, beta, y, info) end subroutine psi_saxpby subroutine psi_saxpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m real(psb_spk_), intent (in) :: x(:) real(psb_spk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_saxpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call saxpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_saxpbyv(m,alpha, x, beta, y, info) end subroutine psi_saxpbyv +subroutine psi_saxpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + real(psb_spk_), intent (in) :: x(:) + real(psb_spk_), intent (in) :: y(:) + real(psb_spk_), intent (inout) :: z(:) + real(psb_spk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call saxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_saxpbyv2 subroutine psi_sgthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_sgthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == szero) then - if (alpha == szero) then + if (beta == szero) then + if (alpha == szero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_sgthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -sone) then + else if (alpha == -sone) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_sgthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == sone) then + else + if (beta == sone) then ! Do nothing - else if (beta == -sone) then - y(1:n*k) = -y(1:n*k) + else if (beta == -sone) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == szero) then + if (alpha == szero) then ! do nothing - else if (alpha == sone) then + else if (alpha == sone) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_sgthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_sgthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == szero) then - if (alpha == szero) then + if (beta == szero) then + if (alpha == szero) then do i=1,n y(i) = szero end do - else if (alpha == sone) then + else if (alpha == sone) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -sone) then + else if (alpha == -sone) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == sone) then + else + if (beta == sone) then ! Do nothing - else if (beta == -sone) then - y(1:n) = -y(1:n) + else if (beta == -sone) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == szero) then + if (alpha == szero) then ! do nothing - else if (alpha == sone) then + else if (alpha == sone) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -sone) then + else if (alpha == -sone) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_sgthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_sgthzv(n,idx,x,y) end subroutine psi_sgthzv subroutine psi_ssctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_ssctmm(n,k,idx,x,beta,y) end subroutine psi_ssctmm subroutine psi_ssctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_ssctv subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info real(psb_spk_) X(lldx,*), Y(lldy,*) real(psb_spk_) alpha, beta @@ -447,19 +508,19 @@ subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.szero) then - if (beta.eq.szero) then - do j=1, n - do i=1,m + if (alpha.eq.szero) then + if (beta.eq.szero) then + do j=1, n + do i=1,m y(i,j) = szero enddo enddo else if (beta.eq.sone) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-sone) then - do j=1,n - do i=1,m + else if (beta.eq.-sone) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.sone) then - if (beta.eq.szero) then - do j=1,n - do i=1,m + if (beta.eq.szero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.sone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-sone) then - do j=1,n - do i=1,m + else if (beta.eq.-sone) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-sone) then + else if (alpha.eq.-sone) then - if (beta.eq.szero) then - do j=1,n - do i=1,m + if (beta.eq.szero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.sone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-sone) then - do j=1,n - do i=1,m + else if (beta.eq.-sone) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.szero) then - do j=1,n - do i=1,m + if (beta.eq.szero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.sone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-sone) then - do j=1,n - do i=1,m + else if (beta.eq.-sone) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine saxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine saxpby + +subroutine saxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + real(psb_spk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + real(psb_spk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='saxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.szero) then + if (beta.eq.szero) then + do j=1, n + do i=1,m + Z(i,j) = szero + enddo + enddo + else if (beta.eq.sone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.sone) then + + if (beta.eq.szero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-sone) then + + if (beta.eq.szero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.szero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.sone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-sone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine saxpbyv2 diff --git a/base/serial/psi_z_serial_impl.f90 b/base/serial/psi_z_serial_impl.f90 index 8d9454304..5b7036e64 100644 --- a/base/serial/psi_z_serial_impl.f90 +++ b/base/serial/psi_z_serial_impl.f90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,13 +27,13 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m, n complex(psb_dpk_), intent (in) :: x(:,:) complex(psb_dpk_), intent (inout) :: y(:,:) @@ -55,27 +55,27 @@ subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (n < 0) then info = psb_err_iarg_neg_ ierr(1) = 2; ierr(2) = n call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then + if (lx < m) then info = psb_err_input_asize_small_i_ ierr(1) = 4; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 6; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if ((m>0).and.(n>0)) call zaxpby(m,n,alpha,x,lx,beta,y,ly,info) @@ -89,10 +89,10 @@ subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) end subroutine psi_zaxpby subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) - + use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_), intent(in) :: m complex(psb_dpk_), intent (in) :: x(:) complex(psb_dpk_), intent (inout) :: y(:) @@ -114,21 +114,21 @@ subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) info = psb_err_iarg_neg_ ierr(1) = 1; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if lx = size(x,1) ly = size(y,1) - if (lx < m) then - info = psb_err_input_asize_small_i_ + if (lx < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 3; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if - if (ly < m) then - info = psb_err_input_asize_small_i_ + if (ly < m) then + info = psb_err_input_asize_small_i_ ierr(1) = 5; ierr(2) = m call psb_errpush(info,name,i_err=ierr) - goto 9999 + goto 9999 end if if (m>0) call zaxpby(m,ione,alpha,x,lx,beta,y,ly,info) @@ -142,6 +142,67 @@ subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) end subroutine psi_zaxpbyv +subroutine psi_zaxpbyv2(m,alpha, x, beta, y, z, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + complex(psb_dpk_), intent (in) :: x(:) + complex(psb_dpk_), intent (in) :: y(:) + complex(psb_dpk_), intent (inout) :: z(:) + complex(psb_dpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly, lz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + lz = size(z,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (lz < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call zaxpbyv2(m,ione,alpha,x,lx,beta,y,ly,z,lz,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_zaxpbyv2 subroutine psi_zgthmv(n,k,idx,alpha,x,beta,y) @@ -154,8 +215,8 @@ subroutine psi_zgthmv(n,k,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == zzero) then - if (alpha == zzero) then + if (beta == zzero) then + if (alpha == zzero) then pt=0 do j=1,k do i=1,n @@ -171,11 +232,11 @@ subroutine psi_zgthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -zone) then + else if (alpha == -zone) then pt=0 do j=1,k do i=1,n - pt=pt+1 + pt=pt+1 y(pt) = -x(idx(i),j) end do end do @@ -188,18 +249,18 @@ subroutine psi_zgthmv(n,k,idx,alpha,x,beta,y) end do end do end if - else - if (beta == zone) then + else + if (beta == zone) then ! Do nothing - else if (beta == -zone) then - y(1:n*k) = -y(1:n*k) + else if (beta == -zone) then + y(1:n*k) = -y(1:n*k) else - y(1:n*k) = beta*y(1:n*k) + y(1:n*k) = beta*y(1:n*k) end if - if (alpha == zzero) then + if (alpha == zzero) then ! do nothing - else if (alpha == zone) then + else if (alpha == zone) then pt=0 do j=1,k do i=1,n @@ -215,7 +276,7 @@ subroutine psi_zgthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) - x(idx(i),j) end do end do - else + else pt=0 do j=1,k do i=1,n @@ -238,44 +299,44 @@ subroutine psi_zgthv(n,idx,alpha,x,beta,y) ! Locals integer(psb_ipk_) :: i - if (beta == zzero) then - if (alpha == zzero) then + if (beta == zzero) then + if (alpha == zzero) then do i=1,n y(i) = zzero end do - else if (alpha == zone) then + else if (alpha == zone) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -zone) then + else if (alpha == -zone) then do i=1,n y(i) = -x(idx(i)) end do - else + else do i=1,n y(i) = alpha*x(idx(i)) end do end if - else - if (beta == zone) then + else + if (beta == zone) then ! Do nothing - else if (beta == -zone) then - y(1:n) = -y(1:n) + else if (beta == -zone) then + y(1:n) = -y(1:n) else - y(1:n) = beta*y(1:n) + y(1:n) = beta*y(1:n) end if - if (alpha == zzero) then + if (alpha == zzero) then ! do nothing - else if (alpha == zone) then + else if (alpha == zone) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -zone) then + else if (alpha == -zone) then do i=1,n y(i) = y(i) - x(idx(i)) end do - else + else do i=1,n y(i) = y(i) + alpha*x(idx(i)) end do @@ -295,7 +356,7 @@ subroutine psi_zgthzmm(n,k,idx,x,y) ! Locals integer(psb_ipk_) :: i - + do i=1,n y(i,1:k)=x(idx(i),1:k) end do @@ -341,7 +402,7 @@ subroutine psi_zgthzv(n,idx,x,y) end subroutine psi_zgthzv subroutine psi_zsctmm(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -367,7 +428,7 @@ subroutine psi_zsctmm(n,k,idx,x,beta,y) end subroutine psi_zsctmm subroutine psi_zsctmv(n,k,idx,x,beta,y) - + use psb_const_mod implicit none @@ -433,7 +494,7 @@ end subroutine psi_zsctv subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod - implicit none + implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info complex(psb_dpk_) X(lldx,*), Y(lldy,*) complex(psb_dpk_) alpha, beta @@ -447,19 +508,19 @@ subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) ! Error handling ! info = psb_success_ - if (m.lt.0) then + if (m.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (n.lt.0) then + else if (n.lt.0) then info=psb_err_iarg_neg_ int_err(1)=1 int_err(2)=n call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldx.lt.max(1,m)) then + else if (lldx.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=5 int_err(2)=1 @@ -467,7 +528,7 @@ subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) int_err(4)=m call fcpsb_errpush(info,name,int_err) goto 9999 - else if (lldy.lt.max(1,m)) then + else if (lldy.lt.max(1,m)) then info=psb_err_iarg_not_gtia_ii_ int_err(1)=8 int_err(2)=1 @@ -477,27 +538,27 @@ subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.zzero) then - if (beta.eq.zzero) then - do j=1, n - do i=1,m + if (alpha.eq.zzero) then + if (beta.eq.zzero) then + do j=1, n + do i=1,m y(i,j) = zzero enddo enddo else if (beta.eq.zone) then - ! - ! Do nothing! - ! + ! + ! Do nothing! + ! - else if (beta.eq.-zone) then - do j=1,n - do i=1,m + else if (beta.eq.-zone) then + do j=1,n + do i=1,m y(i,j) = - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = beta*y(i,j) enddo enddo @@ -505,86 +566,86 @@ subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else if (alpha.eq.zone) then - if (beta.eq.zzero) then - do j=1,n - do i=1,m + if (beta.eq.zzero) then + do j=1,n + do i=1,m y(i,j) = x(i,j) enddo enddo else if (beta.eq.zone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-zone) then - do j=1,n - do i=1,m + else if (beta.eq.-zone) then + do j=1,n + do i=1,m y(i,j) = x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = x(i,j) + beta*y(i,j) enddo enddo endif - else if (alpha.eq.-zone) then + else if (alpha.eq.-zone) then - if (beta.eq.zzero) then - do j=1,n - do i=1,m + if (beta.eq.zzero) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) enddo enddo else if (beta.eq.zone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-zone) then - do j=1,n - do i=1,m + else if (beta.eq.-zone) then + do j=1,n + do i=1,m y(i,j) = -x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = -x(i,j) + beta*y(i,j) enddo enddo endif - else + else - if (beta.eq.zzero) then - do j=1,n - do i=1,m + if (beta.eq.zzero) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) enddo enddo else if (beta.eq.zone) then - do j=1,n - do i=1,m + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-zone) then - do j=1,n - do i=1,m + else if (beta.eq.-zone) then + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) enddo enddo - else - do j=1,n - do i=1,m + else + do j=1,n + do i=1,m y(i,j) = alpha*x(i,j) + beta*y(i,j) enddo enddo @@ -599,3 +660,181 @@ subroutine zaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) return end subroutine zaxpby + +subroutine zaxpbyv2(m, n, alpha, X, lldx, beta, Y, lldy, Z, lldz, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, lldz, info + complex(psb_dpk_) X(lldx,*), Y(lldy,*), Z(lldy,*) + complex(psb_dpk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='zaxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldz.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldz + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.zzero) then + if (beta.eq.zzero) then + do j=1, n + do i=1,m + Z(i,j) = zzero + enddo + enddo + else if (beta.eq.zone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + Z(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.zone) then + + if (beta.eq.zzero) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.zone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + Z(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-zone) then + + if (beta.eq.zzero) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.zone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.zzero) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.zone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-zone) then + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + Z(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine zaxpbyv2 diff --git a/cbind/Makefile b/cbind/Makefile index 9beb16046..2abb6cfe5 100644 --- a/cbind/Makefile +++ b/cbind/Makefile @@ -6,25 +6,26 @@ INCDIR=../include MODDIR=../modules/ LIBNAME=$(CBINDLIBNAME) -lib: based precd krylovd +lib: based precd krylovd utild /bin/cp -p $(CPUPDFLAG) $(HERE)/$(LIBNAME) $(LIBDIR) /bin/cp -p $(CPUPDFLAG) *.h $(INCDIR) - /bin/cp -p $(CPUPDFLAG) *$(.mod) $(MODDIR) + /bin/cp -p $(CPUPDFLAG) *$(.mod) $(MODDIR) based: - cd base && $(MAKE) lib LIBNAME=$(LIBNAME) + cd base && $(MAKE) lib LIBNAME=$(LIBNAME) precd: based - cd prec && $(MAKE) lib LIBNAME=$(LIBNAME) + cd prec && $(MAKE) lib LIBNAME=$(LIBNAME) krylovd: based precd - cd krylov && $(MAKE) lib LIBNAME=$(LIBNAME) + cd krylov && $(MAKE) lib LIBNAME=$(LIBNAME) +utild: based + cd util && $(MAKE) lib LIBNAME=$(LIBNAME) - -clean: +clean: cd base && $(MAKE) clean cd prec && $(MAKE) clean cd krylov && $(MAKE) clean - + cd util && $(MAKE) clean veryclean: clean cd test/pargen && $(MAKE) clean diff --git a/cbind/base/psb_base_tools_cbind_mod.F90 b/cbind/base/psb_base_tools_cbind_mod.F90 index af32c637d..75028e272 100644 --- a/cbind/base/psb_base_tools_cbind_mod.F90 +++ b/cbind/base/psb_base_tools_cbind_mod.F90 @@ -4,27 +4,29 @@ module psb_base_tools_cbind_mod use psb_objhandle_mod use psb_cpenv_mod use psb_base_string_cbind_mod - + contains - + + ! Aggiungere funzione per estrarre comunicatore + function psb_c_error() bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res res = 0 call psb_error() end function psb_c_error - + function psb_c_clean_errstack() bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res res = 0 call psb_clean_errstack() end function psb_c_clean_errstack - - function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res) + implicit none + + integer(psb_c_ipk_) :: res integer(psb_c_lpk_), value :: ng integer(psb_c_ipk_), value :: ictxt integer(psb_c_ipk_) :: vg(*) @@ -33,12 +35,12 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (ng <=0) then + if (ng <=0) then write(0,*) 'Invalid size' return end if - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call descp%free(info) if (info == 0) deallocate(descp,stat=info) @@ -46,32 +48,32 @@ contains end if allocate(descp,stat=info) - if (info < 0) return - + if (info < 0) return + call psb_cdall(ictxt,descp,info,vg=vg(1:ng)) cdh%item = c_loc(descp) res = info end function psb_c_cdall_vg - - - function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res) - implicit none - integer(psb_c_ipk_) :: res + + function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res) + implicit none + + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nl, ictxt integer(psb_c_lpk_) :: vl(*) type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer(psb_c_ipk_) :: info, ixb + integer(psb_c_ipk_) :: info, ixb res = -1 - if (nl <=0) then + if (nl <=0) then write(0,*) 'Invalid size' return end if - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call descp%free(info) if (info == 0) deallocate(descp,stat=info) @@ -79,11 +81,11 @@ contains end if allocate(descp,stat=info) - if (info < 0) return + if (info < 0) return ixb = psb_c_get_index_base() - - if (ixb == 1) then + + if (ixb == 1) then call psb_cdall(ictxt,descp,info,vl=vl(1:nl)) else call psb_cdall(ictxt,descp,info,vl=(vl(1:nl)+(1-ixb))) @@ -94,21 +96,21 @@ contains end function psb_c_cdall_vl function psb_c_cdall_nl(nl,ictxt,cdh) bind(c,name='psb_c_cdall_nl') result(res) - implicit none + implicit none - integer(psb_c_ipk_) :: res + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nl, ictxt type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info res = -1 - if (nl <=0) then + if (nl <=0) then write(0,*) 'Invalid size' return end if - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call descp%free(info) if (info == 0) deallocate(descp,stat=info) @@ -116,8 +118,8 @@ contains end if allocate(descp,stat=info) - if (info < 0) return - + if (info < 0) return + call psb_cdall(ictxt,descp,info,nl=nl) cdh%item = c_loc(descp) res = info @@ -125,9 +127,9 @@ contains end function psb_c_cdall_nl function psb_c_cdall_repl(n,ictxt,cdh) bind(c,name='psb_c_cdall_repl') result(res) - implicit none + implicit none - integer(psb_c_ipk_) :: res + integer(psb_c_ipk_) :: res integer(psb_c_lpk_), value :: n integer(psb_c_ipk_), value :: ictxt type(psb_c_object_type) :: cdh @@ -135,12 +137,12 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (n <=0) then + if (n <=0) then write(0,*) 'Invalid size' return end if - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call descp%free(info) if (info == 0) deallocate(descp,stat=info) @@ -148,25 +150,25 @@ contains end if allocate(descp,stat=info) - if (info < 0) return - + if (info < 0) return + call psb_cdall(ictxt,descp,info,mg=n,repl=.true.) cdh%item = c_loc(descp) res = info end function psb_c_cdall_repl - - function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call psb_cdasb(descp,info) res = info @@ -177,39 +179,39 @@ contains function psb_c_cdfree(cdh) bind(c,name='psb_c_cdfree') result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call descp%free(info) if (info == 0) deallocate(descp,stat=info) if (info /= 0) return cdh%item = c_null_ptr end if - + res = info return end function psb_c_cdfree function psb_c_cdins(nz,ia,ja,cdh) bind(c,name='psb_c_cdins') result(res) - implicit none - integer(psb_c_ipk_) :: res + implicit none + integer(psb_c_ipk_) :: res integer(psb_c_ipk_), value :: nz type(psb_c_object_type) :: cdh integer(psb_c_lpk_) :: ia(*),ja(*) - + type(psb_desc_type), pointer :: descp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) call psb_cdins(nz,ia(1:nz),ja(1:nz),descp,info) res = info @@ -220,9 +222,9 @@ contains function psb_c_cd_get_local_rows(cdh) bind(c,name='psb_c_cd_get_local_rows') result(res) - implicit none + implicit none - integer(psb_c_ipk_) :: res + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -230,7 +232,7 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) res = descp%get_local_rows() @@ -241,9 +243,9 @@ contains function psb_c_cd_get_local_cols(cdh) bind(c,name='psb_c_cd_get_local_cols') result(res) - implicit none + implicit none - integer(psb_c_ipk_) :: res + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -251,7 +253,7 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) res = descp%get_local_cols() @@ -260,9 +262,9 @@ contains end function psb_c_cd_get_local_cols function psb_c_cd_get_global_rows(cdh) bind(c,name='psb_c_cd_get_global_rows') result(res) - implicit none + implicit none - integer(psb_c_lpk_) :: res + integer(psb_c_lpk_) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -270,7 +272,7 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) res = descp%get_global_rows() @@ -281,9 +283,9 @@ contains function psb_c_cd_get_global_cols(cdh) bind(c,name='psb_c_cd_get_global_cols') result(res) - implicit none + implicit none - integer(psb_c_lpk_) :: res + integer(psb_c_lpk_) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -291,7 +293,7 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) res = descp%get_global_cols() @@ -301,4 +303,3 @@ contains end module psb_base_tools_cbind_mod - diff --git a/cbind/base/psb_c_base.c b/cbind/base/psb_c_base.c index 96a6df34f..4683e49cb 100644 --- a/cbind/base/psb_c_base.c +++ b/cbind/base/psb_c_base.c @@ -5,7 +5,7 @@ psb_c_descriptor* psb_c_new_descriptor() { psb_c_descriptor* temp; - + temp=(psb_c_descriptor *) malloc(sizeof(psb_c_descriptor)); temp->descriptor=NULL; return(temp); @@ -13,11 +13,11 @@ psb_c_descriptor* psb_c_new_descriptor() void psb_c_print_errmsg() -{ - char *mesg; - +{ + char *mesg; + for (mesg = psb_c_pop_errmsg(); mesg != NULL; mesg = psb_c_pop_errmsg()) { - fprintf(stderr,"%s\n",mesg); + fprintf(stderr,"%s\n",mesg); free(mesg); } @@ -28,7 +28,7 @@ void psb_c_print_errmsg() #define PSB_MAX_ERR_LINES 4 static int maxlen=PSB_MAX_ERR_LINES*(PSB_MAX_ERRLINE_LEN+2); char *psb_c_pop_errmsg() -{ +{ char *tmp; tmp = (char*) malloc(maxlen*sizeof(char)); if (psb_c_f2c_errmsg(tmp,maxlen)<=0) { @@ -36,4 +36,5 @@ char *psb_c_pop_errmsg() } return(tmp); } - + +// Convertire il comunicatore fortran in comunicatore c diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index c6bea6b6d..c2cd173cf 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -8,11 +8,11 @@ extern "C" { typedef struct PSB_C_CVECTOR { void *cvector; -} psb_c_cvector; +} psb_c_cvector; typedef struct PSB_C_CSPMAT { void *cspmat; -} psb_c_cspmat; +} psb_c_cspmat; /* dense vectors */ @@ -21,6 +21,7 @@ psb_i_t psb_c_cvect_get_nrows(psb_c_cvector *xh); psb_c_t *psb_c_cvect_get_cpy( psb_c_cvector *xh); psb_i_t psb_c_cvect_f_get_cpy(psb_c_t *v, psb_c_cvector *xh); psb_i_t psb_c_cvect_zero(psb_c_cvector *xh); +psb_i_t *psb_c_cvect_f_get_pnt(psb_c_cvector *xh); psb_i_t psb_c_cgeall(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgeins(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val, @@ -39,27 +40,57 @@ psb_i_t psb_c_cspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, const psb_c_t *val, psb_c_cspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_cmat_get_nrows(psb_c_cspmat *mh); psb_i_t psb_c_cmat_get_ncols(psb_c_cspmat *mh); +psb_l_t psb_c_cnnz(psb_c_cspmat *mh,psb_c_descriptor *cdh); +bool psb_c_cis_matupd(psb_c_cspmat *mh,psb_c_descriptor *cdh); +bool psb_c_cis_matasb(psb_c_cspmat *mh,psb_c_descriptor *cdh); +bool psb_c_cis_matbld(psb_c_cspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_cset_matupd(psb_c_cspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_cset_matasb(psb_c_cspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_cset_matbld(psb_c_cspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_ccopy_mat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_c_descriptor *cdh); /* psb_i_t psb_c_cspasb_opt(psb_c_cspmat *mh, psb_c_descriptor *cdh, */ /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_csprn(psb_c_cspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name); +psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name); /* psblas computational routines */ psb_c_t psb_c_cgedot(psb_c_cvector *xh, psb_c_cvector *yh, psb_c_descriptor *cdh); psb_s_t psb_c_cgenrm2(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_s_t psb_c_cgeamax(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_s_t psb_c_cgeasum(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_cspnrmi(psb_c_cspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeaxpby(psb_c_t alpha, psb_c_cvector *xh, +psb_s_t psb_c_cgenrmi(psb_c_cspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_cgeaxpby(psb_c_t alpha, psb_c_cvector *xh, psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspmm(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh, +psb_i_t psb_c_cgeaxpbyz(psb_c_t alpha, psb_c_cvector *xh, + psb_c_t beta, psb_c_cvector *yh, psb_c_cvector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_cspmm(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh, psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspmm_opt(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh, +psb_i_t psb_c_cspmm_opt(psb_c_t alpha, psb_c_cspmat *ah, psb_c_cvector *xh, psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh, char *trans, bool doswap); -psb_i_t psb_c_cspsm(psb_c_t alpha, psb_c_cspmat *th, psb_c_cvector *xh, +psb_i_t psb_c_cspsm(psb_c_t alpha, psb_c_cspmat *th, psb_c_cvector *xh, psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); +/* Additional computational routines */ +psb_i_t psb_c_cgemlt(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_cgemlt2(psb_c_t alpha, psb_c_cvector *xh, psb_c_cvector *yh, psb_c_t beta, psb_c_cvector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_cgediv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_cgediv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_cgediv2(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_cgediv2_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *zh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_cgeinv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_cgeinv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_cgeabs(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_cvector *cdh); +psb_i_t psb_c_cgecmp(psb_c_cvector *xh,psb_s_t ch,psb_c_cvector *zh,psb_c_descriptor *cdh); +bool psb_c_cgecmpmat(psb_c_cspmat *ah,psb_c_cspmat *bh,psb_s_t tol,psb_c_descriptor *cdh); +bool psb_c_cgecmpmat_val(psb_c_cspmat *ah,psb_c_t val,psb_s_t tol,psb_c_descriptor *cdh); +psb_i_t psb_c_cgeaddconst(psb_c_cvector *xh,psb_c_t bh,psb_c_cvector *zh,psb_c_descriptor *cdh); +psb_s_t psb_c_cgenrm2_weight(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_descriptor *cdh); +psb_s_t psb_c_cgenrm2_weightmask(psb_c_cvector *xh,psb_c_cvector *wh,psb_c_cvector *idvh,psb_c_descriptor *cdh); +psb_i_t psb_c_cspscal(psb_c_t alpha, psb_c_cspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_cspscalpid(psb_c_t alpha, psb_c_cspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_cspaxpby(psb_c_t alpha, psb_c_cspmat *ah, psb_c_t beta, psb_c_cspmat *bh, psb_c_descriptor *cdh); + #ifdef __cplusplus } #endif /* __cplusplus */ diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index 95baca5d6..ece7b840b 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -8,11 +8,11 @@ extern "C" { typedef struct PSB_C_DVECTOR { void *dvector; -} psb_c_dvector; +} psb_c_dvector; typedef struct PSB_C_DSPMAT { void *dspmat; -} psb_c_dspmat; +} psb_c_dspmat; /* dense vectors */ @@ -21,6 +21,7 @@ psb_i_t psb_c_dvect_get_nrows(psb_c_dvector *xh); psb_d_t *psb_c_dvect_get_cpy( psb_c_dvector *xh); psb_i_t psb_c_dvect_f_get_cpy(psb_d_t *v, psb_c_dvector *xh); psb_i_t psb_c_dvect_zero(psb_c_dvector *xh); +psb_d_t *psb_c_dvect_f_get_pnt( psb_c_dvector *xh); psb_i_t psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgeins(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, @@ -39,27 +40,61 @@ psb_i_t psb_c_dspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, const psb_d_t *val, psb_c_dspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_dmat_get_nrows(psb_c_dspmat *mh); psb_i_t psb_c_dmat_get_ncols(psb_c_dspmat *mh); +psb_l_t psb_c_dnnz(psb_c_dspmat *mh,psb_c_descriptor *cdh); +bool psb_c_dis_matupd(psb_c_dspmat *mh,psb_c_descriptor *cdh); +bool psb_c_dis_matasb(psb_c_dspmat *mh,psb_c_descriptor *cdh); +bool psb_c_dis_matbld(psb_c_dspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_dset_matupd(psb_c_dspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_dset_matasb(psb_c_dspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_dset_matbld(psb_c_dspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_dcopy_mat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_c_descriptor *cdh); /* psb_i_t psb_c_dspasb_opt(psb_c_dspmat *mh, psb_c_descriptor *cdh, */ /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name); +psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name); /* psblas computational routines */ psb_d_t psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh); psb_d_t psb_c_dgenrm2(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_d_t psb_c_dgeamax(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_d_t psb_c_dgeasum(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_dspnrmi(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeaxpby(psb_d_t alpha, psb_c_dvector *xh, +psb_d_t psb_c_dgenrmi(psb_c_dvector *xh, psb_c_descriptor *cdh); +psb_i_t psb_c_dgeaxpby(psb_d_t alpha, psb_c_dvector *xh, psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspmm(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh, +psb_i_t psb_c_dgeaxpbyz(psb_d_t alpha, psb_c_dvector *xh, + psb_d_t beta, psb_c_dvector *yh, psb_c_dvector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_dspmm(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh, psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspmm_opt(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh, +psb_i_t psb_c_dspmm_opt(psb_d_t alpha, psb_c_dspmat *ah, psb_c_dvector *xh, psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh, char *trans, bool doswap); -psb_i_t psb_c_dspsm(psb_d_t alpha, psb_c_dspmat *th, psb_c_dvector *xh, +psb_i_t psb_c_dspsm(psb_d_t alpha, psb_c_dspmat *th, psb_c_dvector *xh, psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); +/* Additional computational routines */ +psb_i_t psb_c_dgemlt(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgemlt2(psb_d_t alpha, psb_c_dvector *xh, psb_c_dvector *yh, psb_d_t beta, psb_c_dvector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_dgediv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgediv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_dgediv2(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_dvector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgediv2_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_dvector *zh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_dgeinv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgeinv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_dgeabs(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgecmp(psb_c_dvector *xh,psb_d_t ch,psb_c_dvector *zh,psb_c_descriptor *cdh); +bool psb_c_dgecmpmat(psb_c_dspmat *ah,psb_c_dspmat *bh,psb_d_t tol,psb_c_descriptor *cdh); +bool psb_c_dgecmpmat_val(psb_c_dspmat *ah,psb_d_t val,psb_d_t tol,psb_c_descriptor *cdh); +psb_i_t psb_c_dgeaddconst(psb_c_dvector *xh,psb_d_t bh,psb_c_dvector *zh,psb_c_descriptor *cdh); +psb_d_t psb_c_dgenrm2_weight(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_descriptor *cdh); +psb_d_t psb_c_dgenrm2_weightmask(psb_c_dvector *xh,psb_c_dvector *wh,psb_c_dvector *idvh,psb_c_descriptor *cdh); +psb_i_t psb_c_dmask(psb_c_dvector *ch,psb_c_dvector *xh,psb_c_dvector *mh, void *t, psb_c_descriptor *cdh); +psb_d_t psb_c_dgemin(psb_c_dvector *xh,psb_c_descriptor *cdh); +psb_d_t psb_c_dminquotient(psb_c_dvector *xh,psb_c_dvector *yh, psb_c_descriptor *cdh); +psb_i_t psb_c_dspscal(psb_d_t alpha, psb_c_dspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_dspscalpid(psb_d_t alpha, psb_c_dspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_dspaxpby(psb_d_t alpha, psb_c_dspmat *ah, psb_d_t beta, psb_c_dspmat *bh, psb_c_descriptor *cdh); + + #ifdef __cplusplus } #endif /* __cplusplus */ diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index d6604356b..aea9bad2b 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -3,38 +3,38 @@ module psb_c_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - + contains - + function psb_c_cgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh,yh type(psb_c_descriptor) :: cdh complex(c_float_complex), value :: alpha,beta - + type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp,yp integer(psb_c_ipk_) :: info - + res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if call psb_geaxpby(alpha,xp,beta,yp,descp,info) @@ -43,8 +43,535 @@ contains end function psb_c_cgeaxpby + function psb_c_cgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: alpha,beta + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) + + res = info + + end function psb_c_cgeaxpbyz + + function psb_c_cgemlt(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gemlt(xp,yp,descp,info) + + res = info + + end function psb_c_cgemlt + + function psb_c_cgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + complex(psb_spk_), intent(in), value :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_cgemlt2 + + function psb_c_cgediv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gediv(xp,yp,descp,info) + + res = info + + end function psb_c_cgediv + + function psb_c_cgediv2(xh,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gediv(xp,yp,zp,descp,info) + + res = info + + end function psb_c_cgediv2 + + function psb_c_cgediv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_cgediv_check + + function psb_c_cgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,zp,descp,info,fflag) + + res = info + + end function psb_c_cgediv2_check + + function psb_c_cgeinv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geinv(xp,yp,descp,info) + + res = info + + end function psb_c_cgeinv + + function psb_c_cgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_geinv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_cgeinv_check + + function psb_c_cgeabs(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geabs(xp,yp,descp,info) + + res = info + + end function psb_c_cgeabs + + function psb_c_cgecmp(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_float_complex), value :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gecmp(xp,ch,zp,descp,info) + + res = info + + end function psb_c_cgecmp + + function psb_c_cgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_cspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + real(c_float_complex), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call psb_gecmp(ap,bp,tol,descp,isequal,info) + + res = isequal + + end function psb_c_cgecmpmat + + function psb_c_cgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + complex(c_float_complex), value :: val + real(c_float_complex), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call psb_gecmp(ap,val,tol,descp,isequal,info) + + res = isequal + + end function psb_c_cgecmpmat_val + + function psb_c_cgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_float_complex), value :: bh + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaddconst(xp,bh,zp,descp,info) + + res = info + + end function psb_c_cgeaddconst + + function psb_c_cgenrm2(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float_complex) :: res type(psb_c_cvector) :: xh @@ -55,23 +582,123 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_genrm2(xp,descp,info) end function psb_c_cgenrm2 - + + function psb_c_cgenrmi(xh,cdh) bind(c) result(res) + implicit none + real(c_float_complex) :: res + + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp + type(psb_c_vect_type) :: yp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + call psb_geall(yp,descp,info) + call psb_geabs(xp,yp,descp,info) + res = psb_geasum(yp,descp,info) + call psb_gefree(yp,descp,info) + + end function psb_c_cgenrmi + + function psb_c_cgenrm2_weight(xh,wh,cdh) bind(c) result(res) + implicit none + real(c_float_complex) :: res + + type(psb_c_cvector) :: xh, wh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp, wp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + + res = psb_genrm2(xp,wp,descp,info) + + end function psb_c_cgenrm2_weight + + function psb_c_cgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + implicit none + real(c_float_complex) :: res + + type(psb_c_cvector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp, wp, idvp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + if (c_associated(idvh%item)) then + call c_f_pointer(idvh%item,idvp) + else + return + end if + + res = psb_genrm2(xp,wp,idvp,descp,info) + + end function psb_c_cgenrm2_weightmask + function psb_c_cgeamax(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float_complex) :: res type(psb_c_cvector) :: xh @@ -81,23 +708,24 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geamax(xp,descp,info) end function psb_c_cgeamax - + + function psb_c_cgeasum(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float_complex) :: res type(psb_c_cvector) :: xh @@ -108,24 +736,24 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geasum(xp,descp,info) end function psb_c_cgeasum - + function psb_c_cspnrmi(ah,cdh) bind(c) result(res) - implicit none + implicit none real(c_float_complex) :: res type(psb_c_cspmat) :: ah @@ -135,15 +763,15 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if res = psb_spnrmi(ap,descp,info) @@ -151,7 +779,7 @@ contains end function psb_c_cspnrmi function psb_c_cgedot(xh,yh,cdh) bind(c) result(res) - implicit none + implicit none complex(c_float_complex) :: res type(psb_c_cvector) :: xh,yh @@ -161,20 +789,20 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if res = psb_gedot(xp,yp,descp,info) @@ -182,7 +810,7 @@ contains function psb_c_cspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: ah @@ -195,25 +823,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spmm(alpha,ap,xp,beta,yp,descp,info) @@ -224,7 +852,7 @@ contains function psb_c_cspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: ah @@ -242,25 +870,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if fdoswap = doswap @@ -270,10 +898,10 @@ contains res = info end function psb_c_cspmm_opt - + function psb_c_cspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: ah @@ -286,25 +914,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spsm(alpha,ap,xp,beta,yp,descp,info) @@ -312,6 +940,329 @@ contains res = info end function psb_c_cspsm - + + function psb_c_cnnz(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = 0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = psb_nnz(ap,descp,info) + + end function psb_c_cnnz + + function psb_c_cis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_upd() + end function + + function psb_c_cis_matasb(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_asb() + end function + + function psb_c_cis_matbld(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_bld() + end function + + function psb_c_cset_matupd(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_upd() + + res = psb_success_ + end function + + function psb_c_cset_matasb(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + + res = -1; + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_asb() + + res = psb_success_ + + end function + + function psb_c_cset_matbld(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_bld() + + res = psb_success_ + end function + + function psb_c_ccopy_mat(ah,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%clone(bp,info) + + res = info + end function + + function psb_c_cspscal(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + complex(c_float_complex), value :: alpha + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scal(alpha,info) + + res = info + + end function psb_c_cspscal + + function psb_c_cspscalpid(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + complex(c_float_complex), value :: alpha + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scalpid(alpha,info) + + res = info + + end function psb_c_cspscalpid + + function psb_c_cspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + complex(c_float_complex), value :: alpha + type(psb_c_cspmat) :: ah + complex(c_float_complex), value :: beta + type(psb_c_cspmat) :: bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_cspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%spaxpby(alpha,beta,bp,info) + + res = info + end function psb_c_cspaxpby end module psb_c_psblas_cbind_mod diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index 5f5c52343..85333decd 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -8,11 +8,11 @@ extern "C" { typedef struct PSB_C_SVECTOR { void *svector; -} psb_c_svector; +} psb_c_svector; typedef struct PSB_C_SSPMAT { void *sspmat; -} psb_c_sspmat; +} psb_c_sspmat; /* dense vectors */ @@ -21,6 +21,7 @@ psb_i_t psb_c_svect_get_nrows(psb_c_svector *xh); psb_s_t *psb_c_svect_get_cpy( psb_c_svector *xh); psb_i_t psb_c_svect_f_get_cpy(psb_s_t *v, psb_c_svector *xh); psb_i_t psb_c_svect_zero(psb_c_svector *xh); +psb_s_t *psb_c_svect_f_get_pnt( psb_c_svector *xh); psb_i_t psb_c_sgeall(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgeins(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, @@ -39,27 +40,58 @@ psb_i_t psb_c_sspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, const psb_s_t *val, psb_c_sspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_smat_get_nrows(psb_c_sspmat *mh); psb_i_t psb_c_smat_get_ncols(psb_c_sspmat *mh); +psb_l_t psb_c_snnz(psb_c_sspmat *mh,psb_c_descriptor *cdh); +bool psb_c_sis_matupd(psb_c_sspmat *mh,psb_c_descriptor *cdh); +bool psb_c_sis_matasb(psb_c_sspmat *mh,psb_c_descriptor *cdh); +bool psb_c_sis_matbld(psb_c_sspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_sset_matupd(psb_c_sspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_sset_matasb(psb_c_sspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_sset_matbld(psb_c_sspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_scopy_mat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_c_descriptor *cdh); /* psb_i_t psb_c_sspasb_opt(psb_c_sspmat *mh, psb_c_descriptor *cdh, */ /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_ssprn(psb_c_sspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name); +psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name); /* psblas computational routines */ psb_s_t psb_c_sgedot(psb_c_svector *xh, psb_c_svector *yh, psb_c_descriptor *cdh); psb_s_t psb_c_sgenrm2(psb_c_svector *xh, psb_c_descriptor *cdh); psb_s_t psb_c_sgeamax(psb_c_svector *xh, psb_c_descriptor *cdh); psb_s_t psb_c_sgeasum(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_s_t psb_c_sspnrmi(psb_c_sspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeaxpby(psb_s_t alpha, psb_c_svector *xh, +psb_s_t psb_c_sgenrmi(psb_c_sspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_sgeaxpby(psb_s_t alpha, psb_c_svector *xh, psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspmm(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh, +psb_i_t psb_c_sgeaxpbyz(psb_s_t alpha, psb_c_svector *xh, + psb_s_t beta, psb_c_svector *yh, psb_c_svector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_sspmm(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh, psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspmm_opt(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh, +psb_i_t psb_c_sspmm_opt(psb_s_t alpha, psb_c_sspmat *ah, psb_c_svector *xh, psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh, char *trans, bool doswap); -psb_i_t psb_c_sspsm(psb_s_t alpha, psb_c_sspmat *th, psb_c_svector *xh, +psb_i_t psb_c_sspsm(psb_s_t alpha, psb_c_sspmat *th, psb_c_svector *xh, psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); +/* Additional computational routines */ +psb_i_t psb_c_sgemlt(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgemlt2(psb_s_t alpha, psb_c_svector *xh, psb_c_svector *yh, psb_s_t beta, psb_c_svector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_sgediv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgediv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_sgediv2(psb_c_svector *xh,psb_c_svector *yh,psb_c_svector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgediv2_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_svector *zh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_sgeinv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgeinv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_sgeabs(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgecmp(psb_c_svector *xh,psb_s_t ch,psb_c_svector *zh,psb_c_descriptor *cdh); +bool psb_c_sgecmpmat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_s_t tol,psb_c_descriptor *cdh); +bool psb_c_sgecmpmat_val(psb_c_sspmat *ah,psb_s_t val,psb_s_t tol,psb_c_descriptor *cdh); +psb_i_t psb_c_sgeaddconst(psb_c_svector *xh,psb_s_t bh,psb_c_svector *zh,psb_c_descriptor *cdh); +psb_s_t psb_c_sgenrm2_weight(psb_c_svector *xh,psb_c_svector *wh,psb_c_descriptor *cdh); +psb_s_t psb_c_sgenrm2_weightmask(psb_c_svector *xh,psb_c_svector *wh,psb_c_svector *idvh,psb_c_descriptor *cdh); +psb_i_t psb_c_smask(psb_c_svector *ch,psb_c_svector *xh,psb_c_svector *mh, void *t, psb_c_descriptor *cdh); +psb_s_t psb_c_sgemin(psb_c_svector *xh,psb_c_descriptor *cdh); +psb_i_t psb_c_sspscal(psb_s_t alpha, psb_c_sspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_sspscalpid(psb_s_t alpha, psb_c_sspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_sspaxpby(psb_s_t alpha, psb_c_sspmat *ah, psb_s_t beta, psb_c_sspmat *bh, psb_c_descriptor *cdh); #ifdef __cplusplus } #endif /* __cplusplus */ diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index 5c05abd0e..d46e776ce 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -7,11 +7,11 @@ module psb_c_serial_cbind_mod contains - - function psb_c_cvect_get_nrows(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_cvect_get_nrows(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh type(psb_c_vect_type), pointer :: vp @@ -19,27 +19,27 @@ contains res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) res = vp%get_nrows() end if end function psb_c_cvect_get_nrows - - function psb_c_cvect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_cvect_f_get_cpy(v,xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res complex(c_float_complex) :: v(*) type(psb_c_cvector) :: xh - + type(psb_c_vect_type), pointer :: vp complex(psb_spk_), allocatable :: fv(:) integer(psb_c_ipk_) :: info, sz res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) fv = vp%get_vect() sz = size(fv) @@ -48,31 +48,49 @@ contains end function psb_c_cvect_f_get_cpy - - function psb_c_cvect_zero(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_cvect_zero(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_cvector) :: xh - + type(psb_c_vect_type), pointer :: vp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) call vp%zero() end if end function psb_c_cvect_zero - + function psb_c_cvect_f_get_pnt(xh) bind(c) result(res) + implicit none + + type(c_ptr) :: res + type(psb_c_cvector) :: xh + + type(psb_c_vect_type), pointer :: vp + + res = c_null_ptr + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + if(vp%is_dev()) call vp%sync() + res = c_loc(vp%v%v) + end if + + end function psb_c_cvect_f_get_pnt + + function psb_c_cmat_get_nrows(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh @@ -80,22 +98,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_nrows() end function psb_c_cmat_get_nrows - + function psb_c_cmat_get_ncols(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_cspmat) :: mh @@ -103,22 +121,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_ncols() end function psb_c_cmat_get_ncols - + function psb_c_cmat_name_print(mh,name) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res character(c_char) :: name(*) @@ -128,17 +146,16 @@ contains character(1024) :: fname res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call stringc2f(name,fname) - + call ap%print(fname,head='PSBLAS Cbinding Interface') end function psb_c_cmat_name_print - + end module psb_c_serial_cbind_mod - diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index f61f64cf8..48250c555 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -8,11 +8,11 @@ extern "C" { typedef struct PSB_C_ZVECTOR { void *zvector; -} psb_c_zvector; +} psb_c_zvector; typedef struct PSB_C_ZSPMAT { void *zspmat; -} psb_c_zspmat; +} psb_c_zspmat; /* dense vectors */ @@ -21,6 +21,7 @@ psb_i_t psb_c_zvect_get_nrows(psb_c_zvector *xh); psb_z_t *psb_c_zvect_get_cpy( psb_c_zvector *xh); psb_i_t psb_c_zvect_f_get_cpy(psb_z_t *v, psb_c_zvector *xh); psb_i_t psb_c_zvect_zero(psb_c_zvector *xh); +psb_z_t *psb_c_zvect_f_get_pnt( psb_c_zvector *xh); psb_i_t psb_c_zgeall(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgeins(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val, @@ -39,27 +40,58 @@ psb_i_t psb_c_zspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, const psb_z_t *val, psb_c_zspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_zmat_get_nrows(psb_c_zspmat *mh); psb_i_t psb_c_zmat_get_ncols(psb_c_zspmat *mh); +psb_l_t psb_c_znnz(psb_c_zspmat *mh,psb_c_descriptor *cdh); +bool psb_c_zis_matupd(psb_c_zspmat *mh,psb_c_descriptor *cdh); +bool psb_c_zis_matasb(psb_c_zspmat *mh,psb_c_descriptor *cdh); +bool psb_c_zis_matbld(psb_c_zspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_zset_matupd(psb_c_zspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_zset_matasb(psb_c_zspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_zset_matbld(psb_c_zspmat *mh,psb_c_descriptor *cdh); +psb_i_t psb_c_zcopy_mat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_c_descriptor *cdh); + /* psb_i_t psb_c_zspasb_opt(psb_c_zspmat *mh, psb_c_descriptor *cdh, */ /* const char *afmt, psb_i_t upd, psb_i_t dupl); */ psb_i_t psb_c_zsprn(psb_c_zspmat *mh, psb_c_descriptor *cdh, _Bool clear); -psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name); +psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name); /* psblas computational routines */ psb_z_t psb_c_zgedot(psb_c_zvector *xh, psb_c_zvector *yh, psb_c_descriptor *cdh); psb_d_t psb_c_zgenrm2(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_d_t psb_c_zgeamax(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_d_t psb_c_zgeasum(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_d_t psb_c_zspnrmi(psb_c_zspmat *ah, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeaxpby(psb_z_t alpha, psb_c_zvector *xh, +psb_d_t psb_c_zgenrmi(psb_c_zspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_zgeaxpby(psb_z_t alpha, psb_c_zvector *xh, psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspmm(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh, +psb_i_t psb_c_zgeaxpbyz(psb_z_t alpha, psb_c_zvector *xh, + psb_z_t beta, psb_c_zvector *yh, psb_c_zvector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_zspmm(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh, psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspmm_opt(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh, +psb_i_t psb_c_zspmm_opt(psb_z_t alpha, psb_c_zspmat *ah, psb_c_zvector *xh, psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh, char *trans, bool doswap); -psb_i_t psb_c_zspsm(psb_z_t alpha, psb_c_zspmat *th, psb_c_zvector *xh, +psb_i_t psb_c_zspsm(psb_z_t alpha, psb_c_zspmat *th, psb_c_zvector *xh, psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); +/* Additional computational routines */ +psb_i_t psb_c_zgemlt(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgemlt2(psb_z_t alpha, psb_c_zvector *xh, psb_c_zvector *yh, psb_z_t beta, psb_c_zvector *zh, psb_c_descriptor *cdh); +psb_i_t psb_c_zgediv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgediv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_zgediv2(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_zvector *zh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgediv2_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_zvector *zh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_zgeinv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgeinv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh, bool flag); +psb_i_t psb_c_zgeabs(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgecmp(psb_c_zvector *xh,psb_d_t ch,psb_c_zvector *zh,psb_c_descriptor *cdh); +bool psb_c_zgecmpmat(psb_c_zspmat *ah,psb_c_zspmat *bh,psb_d_t tol,psb_c_descriptor *cdh); +bool psb_c_zgecmpmat_val(psb_c_zspmat *ah,psb_z_t val,psb_d_t tol,psb_c_descriptor *cdh); +psb_i_t psb_c_zgeaddconst(psb_c_zvector *xh,psb_z_t bh,psb_c_zvector *zh,psb_c_descriptor *cdh); +psb_d_t psb_c_zgenrm2_weight(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_descriptor *cdh); +psb_d_t psb_c_zgenrm2_weightmask(psb_c_zvector *xh,psb_c_zvector *wh,psb_c_zvector *idvh,psb_c_descriptor *cdh); +psb_i_t psb_c_zspscal(psb_z_t alpha, psb_c_zspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_zspscalpid(psb_z_t alpha, psb_c_zspmat *ah, psb_c_descriptor *cdh); +psb_i_t psb_c_zspaxpby(psb_z_t alpha, psb_c_zspmat *ah, psb_z_t beta, psb_c_zspmat *bh, psb_c_descriptor *cdh); + #ifdef __cplusplus } #endif /* __cplusplus */ diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 353339d88..07c4d9323 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -3,38 +3,38 @@ module psb_d_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - + contains - + function psb_c_dgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh,yh type(psb_c_descriptor) :: cdh real(c_double), value :: alpha,beta - + type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp,yp integer(psb_c_ipk_) :: info - + res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if call psb_geaxpby(alpha,xp,beta,yp,descp,info) @@ -43,8 +43,611 @@ contains end function psb_c_dgeaxpby + function psb_c_dgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + real(c_double), value :: alpha,beta + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) + + res = info + + end function psb_c_dgeaxpbyz + + function psb_c_dgemlt(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gemlt(xp,yp,descp,info) + + res = info + + end function psb_c_dgemlt + + function psb_c_dgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + real(psb_dpk_), intent(in), value :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_dgemlt2 + + function psb_c_dgediv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gediv(xp,yp,descp,info) + + res = info + + end function psb_c_dgediv + + function psb_c_dgediv2(xh,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gediv(xp,yp,zp,descp,info) + + res = info + + end function psb_c_dgediv2 + + function psb_c_dgediv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_dgediv_check + + function psb_c_dgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,zp,descp,info,fflag) + + res = info + + end function psb_c_dgediv2_check + + function psb_c_dgeinv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geinv(xp,yp,descp,info) + + res = info + + end function psb_c_dgeinv + + function psb_c_dgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_geinv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_dgeinv_check + + function psb_c_dgeabs(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geabs(xp,yp,descp,info) + + res = info + + end function psb_c_dgeabs + + function psb_c_dgecmp(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_double), value :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gecmp(xp,ch,zp,descp,info) + + res = info + + end function psb_c_dgecmp + + function psb_c_dgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_dspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + real(c_double), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call psb_gecmp(ap,bp,tol,descp,isequal,info) + + res = isequal + + end function psb_c_dgecmpmat + + function psb_c_dgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + real(c_double), value :: val + real(c_double), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call psb_gecmp(ap,val,tol,descp,isequal,info) + + res = isequal + + end function psb_c_dgecmpmat_val + + function psb_c_dgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_double), value :: bh + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaddconst(xp,bh,zp,descp,info) + + res = info + + end function psb_c_dgeaddconst + + function psb_c_dmask(ch,xh,mh,t,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: ch,xh,mh + type(psb_c_descriptor) :: cdh + type(c_ptr), value :: t + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: cp,xp,mp + integer(psb_c_ipk_) :: info + logical, pointer :: fp + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ch%item)) then + call c_f_pointer(ch%item,cp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,mp) + else + return + end if + call c_f_pointer(t,fp) + + call psb_mask(cp,xp,mp,fp,descp,info) + + res = info + + end function psb_c_dmask + + function psb_c_dminquotient(xh,yh,cdh) bind(c) result(res) + implicit none + real(psb_dpk_) :: res + + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + res = psb_minquotient(xp,yp,descp,info) + + + end function psb_c_dminquotient + function psb_c_dgenrm2(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double) :: res type(psb_c_dvector) :: xh @@ -55,23 +658,123 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_genrm2(xp,descp,info) end function psb_c_dgenrm2 - + + function psb_c_dgenrmi(xh,cdh) bind(c) result(res) + implicit none + real(c_double) :: res + + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + type(psb_d_vect_type) :: yp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + call psb_geall(yp,descp,info) + call psb_geabs(xp,yp,descp,info) + res = psb_geasum(yp,descp,info) + call psb_gefree(yp,descp,info) + + end function psb_c_dgenrmi + + function psb_c_dgenrm2_weight(xh,wh,cdh) bind(c) result(res) + implicit none + real(c_double) :: res + + type(psb_c_dvector) :: xh, wh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp, wp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + + res = psb_genrm2(xp,wp,descp,info) + + end function psb_c_dgenrm2_weight + + function psb_c_dgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + implicit none + real(c_double) :: res + + type(psb_c_dvector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp, wp, idvp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + if (c_associated(idvh%item)) then + call c_f_pointer(idvh%item,idvp) + else + return + end if + + res = psb_genrm2(xp,wp,idvp,descp,info) + + end function psb_c_dgenrm2_weightmask + function psb_c_dgeamax(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double) :: res type(psb_c_dvector) :: xh @@ -81,23 +784,49 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geamax(xp,descp,info) end function psb_c_dgeamax - + + function psb_c_dgemin(xh,cdh) bind(c) result(res) + implicit none + real(c_double) :: res + + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + + res = -1.0 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + res = psb_gemin(xp,descp,info) + + end function psb_c_dgemin + function psb_c_dgeasum(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double) :: res type(psb_c_dvector) :: xh @@ -108,24 +837,24 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geasum(xp,descp,info) end function psb_c_dgeasum - + function psb_c_dspnrmi(ah,cdh) bind(c) result(res) - implicit none + implicit none real(c_double) :: res type(psb_c_dspmat) :: ah @@ -135,15 +864,15 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if res = psb_spnrmi(ap,descp,info) @@ -151,7 +880,7 @@ contains end function psb_c_dspnrmi function psb_c_dgedot(xh,yh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double) :: res type(psb_c_dvector) :: xh,yh @@ -161,20 +890,20 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if res = psb_gedot(xp,yp,descp,info) @@ -182,7 +911,7 @@ contains function psb_c_dspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: ah @@ -195,25 +924,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spmm(alpha,ap,xp,beta,yp,descp,info) @@ -224,7 +953,7 @@ contains function psb_c_dspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: ah @@ -242,25 +971,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if fdoswap = doswap @@ -270,10 +999,10 @@ contains res = info end function psb_c_dspmm_opt - + function psb_c_dspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: ah @@ -286,25 +1015,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spsm(alpha,ap,xp,beta,yp,descp,info) @@ -312,6 +1041,329 @@ contains res = info end function psb_c_dspsm - + + function psb_c_dnnz(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = 0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = psb_nnz(ap,descp,info) + + end function psb_c_dnnz + + function psb_c_dis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_upd() + end function + + function psb_c_dis_matasb(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_asb() + end function + + function psb_c_dis_matbld(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_bld() + end function + + function psb_c_dset_matupd(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_upd() + + res = psb_success_ + end function + + function psb_c_dset_matasb(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + + res = -1; + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_asb() + + res = psb_success_ + + end function + + function psb_c_dset_matbld(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_bld() + + res = psb_success_ + end function + + function psb_c_dcopy_mat(ah,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%clone(bp,info) + + res = info + end function + + function psb_c_dspscal(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + real(c_double), value :: alpha + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scal(alpha,info) + + res = info + + end function psb_c_dspscal + + function psb_c_dspscalpid(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + real(c_double), value :: alpha + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scalpid(alpha,info) + + res = info + + end function psb_c_dspscalpid + + function psb_c_dspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + real(c_double), value :: alpha + type(psb_c_dspmat) :: ah + real(c_double), value :: beta + type(psb_c_dspmat) :: bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_dspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%spaxpby(alpha,beta,bp,info) + + res = info + end function psb_c_dspaxpby end module psb_d_psblas_cbind_mod diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index d8c1e7291..f8f742fc1 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -7,11 +7,11 @@ module psb_d_serial_cbind_mod contains - - function psb_c_dvect_get_nrows(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_dvect_get_nrows(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh type(psb_d_vect_type), pointer :: vp @@ -19,27 +19,27 @@ contains res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) res = vp%get_nrows() end if end function psb_c_dvect_get_nrows - - function psb_c_dvect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_dvect_f_get_cpy(v,xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res real(c_double) :: v(*) type(psb_c_dvector) :: xh - + type(psb_d_vect_type), pointer :: vp real(psb_dpk_), allocatable :: fv(:) integer(psb_c_ipk_) :: info, sz res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) fv = vp%get_vect() sz = size(fv) @@ -48,31 +48,49 @@ contains end function psb_c_dvect_f_get_cpy - - function psb_c_dvect_zero(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_dvect_zero(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_dvector) :: xh - + type(psb_d_vect_type), pointer :: vp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) call vp%zero() end if end function psb_c_dvect_zero - + function psb_c_dvect_f_get_pnt(xh) bind(c) result(res) + implicit none + + type(c_ptr) :: res + type(psb_c_dvector) :: xh + + type(psb_d_vect_type), pointer :: vp + + res = c_null_ptr + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + if(vp%is_dev()) call vp%sync() + res = c_loc(vp%v%v) + end if + + end function psb_c_dvect_f_get_pnt + + function psb_c_dmat_get_nrows(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh @@ -80,22 +98,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_nrows() end function psb_c_dmat_get_nrows - + function psb_c_dmat_get_ncols(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_dspmat) :: mh @@ -103,22 +121,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_ncols() end function psb_c_dmat_get_ncols - + function psb_c_dmat_name_print(mh,name) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res character(c_char) :: name(*) @@ -128,17 +146,16 @@ contains character(1024) :: fname res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call stringc2f(name,fname) - + call ap%print(fname,head='PSBLAS Cbinding Interface') end function psb_c_dmat_name_print - + end module psb_d_serial_cbind_mod - diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index 918430760..271d8a1c7 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -3,38 +3,38 @@ module psb_s_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - + contains - + function psb_c_sgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh,yh type(psb_c_descriptor) :: cdh real(c_float), value :: alpha,beta - + type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp,yp integer(psb_c_ipk_) :: info - + res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if call psb_geaxpby(alpha,xp,beta,yp,descp,info) @@ -43,8 +43,611 @@ contains end function psb_c_sgeaxpby + function psb_c_sgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + real(c_float), value :: alpha,beta + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) + + res = info + + end function psb_c_sgeaxpbyz + + function psb_c_sgemlt(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gemlt(xp,yp,descp,info) + + res = info + + end function psb_c_sgemlt + + function psb_c_sgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + real(psb_spk_), intent(in), value :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_sgemlt2 + + function psb_c_sgediv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gediv(xp,yp,descp,info) + + res = info + + end function psb_c_sgediv + + function psb_c_sgediv2(xh,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gediv(xp,yp,zp,descp,info) + + res = info + + end function psb_c_sgediv2 + + function psb_c_sgediv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_sgediv_check + + function psb_c_sgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,zp,descp,info,fflag) + + res = info + + end function psb_c_sgediv2_check + + function psb_c_sgeinv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geinv(xp,yp,descp,info) + + res = info + + end function psb_c_sgeinv + + function psb_c_sgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_geinv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_sgeinv_check + + function psb_c_sgeabs(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geabs(xp,yp,descp,info) + + res = info + + end function psb_c_sgeabs + + function psb_c_sgecmp(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_float), value :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gecmp(xp,ch,zp,descp,info) + + res = info + + end function psb_c_sgecmp + + function psb_c_sgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_sspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + real(c_float), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call psb_gecmp(ap,bp,tol,descp,isequal,info) + + res = isequal + + end function psb_c_sgecmpmat + + function psb_c_sgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + real(c_float), value :: val + real(c_float), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call psb_gecmp(ap,val,tol,descp,isequal,info) + + res = isequal + + end function psb_c_sgecmpmat_val + + function psb_c_sgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_float), value :: bh + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaddconst(xp,bh,zp,descp,info) + + res = info + + end function psb_c_sgeaddconst + + function psb_c_smask(ch,xh,mh,t,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: ch,xh,mh + type(psb_c_descriptor) :: cdh + type(c_ptr), value :: t + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: cp,xp,mp + integer(psb_c_ipk_) :: info + logical, pointer :: fp + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ch%item)) then + call c_f_pointer(ch%item,cp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(mh%item)) then + call c_f_pointer(mh%item,mp) + else + return + end if + call c_f_pointer(t,fp) + + call psb_mask(cp,xp,mp,fp,descp,info) + + res = info + + end function psb_c_smask + + function psb_c_sminquotient(xh,yh,cdh) bind(c) result(res) + implicit none + real(psb_spk_) :: res + + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + res = psb_minquotient(xp,yp,descp,info) + + + end function psb_c_sminquotient + function psb_c_sgenrm2(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float) :: res type(psb_c_svector) :: xh @@ -55,23 +658,123 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_genrm2(xp,descp,info) end function psb_c_sgenrm2 - + + function psb_c_sgenrmi(xh,cdh) bind(c) result(res) + implicit none + real(c_float) :: res + + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp + type(psb_s_vect_type) :: yp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + call psb_geall(yp,descp,info) + call psb_geabs(xp,yp,descp,info) + res = psb_geasum(yp,descp,info) + call psb_gefree(yp,descp,info) + + end function psb_c_sgenrmi + + function psb_c_sgenrm2_weight(xh,wh,cdh) bind(c) result(res) + implicit none + real(c_float) :: res + + type(psb_c_svector) :: xh, wh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp, wp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + + res = psb_genrm2(xp,wp,descp,info) + + end function psb_c_sgenrm2_weight + + function psb_c_sgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + implicit none + real(c_float) :: res + + type(psb_c_svector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp, wp, idvp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + if (c_associated(idvh%item)) then + call c_f_pointer(idvh%item,idvp) + else + return + end if + + res = psb_genrm2(xp,wp,idvp,descp,info) + + end function psb_c_sgenrm2_weightmask + function psb_c_sgeamax(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float) :: res type(psb_c_svector) :: xh @@ -81,23 +784,49 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geamax(xp,descp,info) end function psb_c_sgeamax - + + function psb_c_sgemin(xh,cdh) bind(c) result(res) + implicit none + real(c_float) :: res + + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + + res = -1.0 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + res = psb_gemin(xp,descp,info) + + end function psb_c_sgemin + function psb_c_sgeasum(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float) :: res type(psb_c_svector) :: xh @@ -108,24 +837,24 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geasum(xp,descp,info) end function psb_c_sgeasum - + function psb_c_sspnrmi(ah,cdh) bind(c) result(res) - implicit none + implicit none real(c_float) :: res type(psb_c_sspmat) :: ah @@ -135,15 +864,15 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if res = psb_spnrmi(ap,descp,info) @@ -151,7 +880,7 @@ contains end function psb_c_sspnrmi function psb_c_sgedot(xh,yh,cdh) bind(c) result(res) - implicit none + implicit none real(c_float) :: res type(psb_c_svector) :: xh,yh @@ -161,20 +890,20 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if res = psb_gedot(xp,yp,descp,info) @@ -182,7 +911,7 @@ contains function psb_c_sspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: ah @@ -195,25 +924,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spmm(alpha,ap,xp,beta,yp,descp,info) @@ -224,7 +953,7 @@ contains function psb_c_sspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: ah @@ -242,25 +971,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if fdoswap = doswap @@ -270,10 +999,10 @@ contains res = info end function psb_c_sspmm_opt - + function psb_c_sspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: ah @@ -286,25 +1015,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spsm(alpha,ap,xp,beta,yp,descp,info) @@ -312,6 +1041,329 @@ contains res = info end function psb_c_sspsm - + + function psb_c_snnz(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = 0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = psb_nnz(ap,descp,info) + + end function psb_c_snnz + + function psb_c_sis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_upd() + end function + + function psb_c_sis_matasb(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_asb() + end function + + function psb_c_sis_matbld(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_bld() + end function + + function psb_c_sset_matupd(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_upd() + + res = psb_success_ + end function + + function psb_c_sset_matasb(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + + res = -1; + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_asb() + + res = psb_success_ + + end function + + function psb_c_sset_matbld(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_bld() + + res = psb_success_ + end function + + function psb_c_scopy_mat(ah,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_sspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%clone(bp,info) + + res = info + end function + + function psb_c_sspscal(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + real(c_float), value :: alpha + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scal(alpha,info) + + res = info + + end function psb_c_sspscal + + function psb_c_sspscalpid(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + real(c_float), value :: alpha + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scalpid(alpha,info) + + res = info + + end function psb_c_sspscalpid + + function psb_c_sspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + real(c_float), value :: alpha + type(psb_c_sspmat) :: ah + real(c_float), value :: beta + type(psb_c_sspmat) :: bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_sspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%spaxpby(alpha,beta,bp,info) + + res = info + end function psb_c_sspaxpby end module psb_s_psblas_cbind_mod diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index 5df7ff899..65a0bae7c 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -7,11 +7,11 @@ module psb_s_serial_cbind_mod contains - - function psb_c_svect_get_nrows(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_svect_get_nrows(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh type(psb_s_vect_type), pointer :: vp @@ -19,27 +19,27 @@ contains res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) res = vp%get_nrows() end if end function psb_c_svect_get_nrows - - function psb_c_svect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_svect_f_get_cpy(v,xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res real(c_float) :: v(*) type(psb_c_svector) :: xh - + type(psb_s_vect_type), pointer :: vp real(psb_spk_), allocatable :: fv(:) integer(psb_c_ipk_) :: info, sz res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) fv = vp%get_vect() sz = size(fv) @@ -48,31 +48,49 @@ contains end function psb_c_svect_f_get_cpy - - function psb_c_svect_zero(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_svect_zero(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_svector) :: xh - + type(psb_s_vect_type), pointer :: vp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) call vp%zero() end if end function psb_c_svect_zero - + function psb_c_svect_f_get_pnt(xh) bind(c) result(res) + implicit none + + type(c_ptr) :: res + type(psb_c_svector) :: xh + + type(psb_s_vect_type), pointer :: vp + + res = c_null_ptr + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + if(vp%is_dev()) call vp%sync() + res = c_loc(vp%v%v) + end if + + end function psb_c_svect_f_get_pnt + + function psb_c_smat_get_nrows(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh @@ -80,22 +98,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_nrows() end function psb_c_smat_get_nrows - + function psb_c_smat_get_ncols(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_sspmat) :: mh @@ -103,22 +121,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_ncols() end function psb_c_smat_get_ncols - + function psb_c_smat_name_print(mh,name) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res character(c_char) :: name(*) @@ -128,17 +146,16 @@ contains character(1024) :: fname res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call stringc2f(name,fname) - + call ap%print(fname,head='PSBLAS Cbinding Interface') end function psb_c_smat_name_print - + end module psb_s_serial_cbind_mod - diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index 6f0cfd6f3..0254860ba 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -3,38 +3,38 @@ module psb_z_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - + contains - + function psb_c_zgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh,yh type(psb_c_descriptor) :: cdh complex(c_double_complex), value :: alpha,beta - + type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp,yp integer(psb_c_ipk_) :: info - + res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if call psb_geaxpby(alpha,xp,beta,yp,descp,info) @@ -43,8 +43,535 @@ contains end function psb_c_zgeaxpby + function psb_c_zgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: alpha,beta + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) + + res = info + + end function psb_c_zgeaxpbyz + + function psb_c_zgemlt(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gemlt(xp,yp,descp,info) + + res = info + + end function psb_c_zgemlt + + function psb_c_zgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + complex(psb_dpk_), intent(in), value :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_zgemlt2 + + function psb_c_zgediv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_gediv(xp,yp,descp,info) + + res = info + + end function psb_c_zgediv + + function psb_c_zgediv2(xh,yh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gediv(xp,yp,zp,descp,info) + + res = info + + end function psb_c_zgediv2 + + function psb_c_zgediv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_zgediv_check + + function psb_c_zgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + fflag = flag + call psb_gediv(xp,yp,zp,descp,info,fflag) + + res = info + + end function psb_c_zgediv2_check + + function psb_c_zgeinv(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geinv(xp,yp,descp,info) + + res = info + + end function psb_c_zgeinv + + function psb_c_zgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + logical :: fflag + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + fflag = flag + call psb_geinv(xp,yp,descp,info,fflag) + + res = info + + end function psb_c_zgeinv_check + + function psb_c_zgeabs(xh,yh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + + call psb_geabs(xp,yp,descp,info) + + res = info + + end function psb_c_zgeabs + + function psb_c_zgecmp(xh,ch,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_double_complex), value :: ch + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gecmp(xp,ch,zp,descp,info) + + res = info + + end function psb_c_zgecmp + + function psb_c_zgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_zspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + real(c_double_complex), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call psb_gecmp(ap,bp,tol,descp,isequal,info) + + res = isequal + + end function psb_c_zgecmpmat + + function psb_c_zgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + complex(c_double_complex), value :: val + real(c_double_complex), value :: tol + logical :: isequal + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call psb_gecmp(ap,val,tol,descp,isequal,info) + + res = isequal + + end function psb_c_zgecmpmat_val + + function psb_c_zgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,zh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,zp + integer(psb_c_ipk_) :: info + real(c_double_complex), value :: bh + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_geaddconst(xp,bh,zp,descp,info) + + res = info + + end function psb_c_zgeaddconst + + function psb_c_zgenrm2(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double_complex) :: res type(psb_c_zvector) :: xh @@ -55,23 +582,123 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_genrm2(xp,descp,info) end function psb_c_zgenrm2 - + + function psb_c_zgenrmi(xh,cdh) bind(c) result(res) + implicit none + real(c_double_complex) :: res + + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp + type(psb_z_vect_type) :: yp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + call psb_geall(yp,descp,info) + call psb_geabs(xp,yp,descp,info) + res = psb_geasum(yp,descp,info) + call psb_gefree(yp,descp,info) + + end function psb_c_zgenrmi + + function psb_c_zgenrm2_weight(xh,wh,cdh) bind(c) result(res) + implicit none + real(c_double_complex) :: res + + type(psb_c_zvector) :: xh, wh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp, wp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + + res = psb_genrm2(xp,wp,descp,info) + + end function psb_c_zgenrm2_weight + + function psb_c_zgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + implicit none + real(c_double_complex) :: res + + type(psb_c_zvector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp, wp, idvp + integer(psb_c_ipk_) :: info + + res = -1.0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(wh%item)) then + call c_f_pointer(wh%item,wp) + else + return + end if + if (c_associated(idvh%item)) then + call c_f_pointer(idvh%item,idvp) + else + return + end if + + res = psb_genrm2(xp,wp,idvp,descp,info) + + end function psb_c_zgenrm2_weightmask + function psb_c_zgeamax(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double_complex) :: res type(psb_c_zvector) :: xh @@ -81,23 +708,24 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geamax(xp,descp,info) end function psb_c_zgeamax - + + function psb_c_zgeasum(xh,cdh) bind(c) result(res) - implicit none + implicit none real(c_double_complex) :: res type(psb_c_zvector) :: xh @@ -108,24 +736,24 @@ contains res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - + res = psb_geasum(xp,descp,info) end function psb_c_zgeasum - + function psb_c_zspnrmi(ah,cdh) bind(c) result(res) - implicit none + implicit none real(c_double_complex) :: res type(psb_c_zspmat) :: ah @@ -135,15 +763,15 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if res = psb_spnrmi(ap,descp,info) @@ -151,7 +779,7 @@ contains end function psb_c_zspnrmi function psb_c_zgedot(xh,yh,cdh) bind(c) result(res) - implicit none + implicit none complex(c_double_complex) :: res type(psb_c_zvector) :: xh,yh @@ -161,20 +789,20 @@ contains integer(psb_c_ipk_) :: info res = -1.0 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if res = psb_gedot(xp,yp,descp,info) @@ -182,7 +810,7 @@ contains function psb_c_zspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: ah @@ -195,25 +823,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spmm(alpha,ap,xp,beta,yp,descp,info) @@ -224,7 +852,7 @@ contains function psb_c_zspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: ah @@ -242,25 +870,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if fdoswap = doswap @@ -270,10 +898,10 @@ contains res = info end function psb_c_zspmm_opt - + function psb_c_zspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: ah @@ -286,25 +914,25 @@ contains integer(psb_c_ipk_) :: info res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(yh%item)) then + if (c_associated(yh%item)) then call c_f_pointer(yh%item,yp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if call psb_spsm(alpha,ap,xp,beta,yp,descp,info) @@ -312,6 +940,329 @@ contains res = info end function psb_c_zspsm - + + function psb_c_znnz(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = 0 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = psb_nnz(ap,descp,info) + + end function psb_c_znnz + + function psb_c_zis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_upd() + end function + + function psb_c_zis_matasb(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_asb() + end function + + function psb_c_zis_matbld(ah,cdh) bind(c) result(res) + implicit none + logical(c_bool) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = .false. + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + res = ap%is_bld() + end function + + function psb_c_zset_matupd(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_upd() + + res = psb_success_ + end function + + function psb_c_zset_matasb(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + + res = -1; + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_asb() + + res = psb_success_ + + end function + + function psb_c_zset_matbld(ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%set_bld() + + res = psb_success_ + end function + + function psb_c_zcopy_mat(ah,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%clone(bp,info) + + res = info + end function + + function psb_c_zspscal(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + complex(c_double_complex), value :: alpha + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scal(alpha,info) + + res = info + + end function psb_c_zspscal + + function psb_c_zspscalpid(alpha,ah,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + complex(c_double_complex), value :: alpha + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call ap%scalpid(alpha,info) + + res = info + + end function psb_c_zspscalpid + + function psb_c_zspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + complex(c_double_complex), value :: alpha + type(psb_c_zspmat) :: ah + complex(c_double_complex), value :: beta + type(psb_c_zspmat) :: bh + type(psb_c_descriptor) :: cdh + + type(psb_desc_type), pointer :: descp + type(psb_zspmat_type), pointer :: ap,bp + integer(psb_c_ipk_) :: info + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + if (c_associated(bh%item)) then + call c_f_pointer(bh%item,bp) + else + return + end if + + call ap%spaxpby(alpha,beta,bp,info) + + res = info + end function psb_c_zspaxpby end module psb_z_psblas_cbind_mod diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index 27cfa76ac..01dfa0182 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -7,11 +7,11 @@ module psb_z_serial_cbind_mod contains - - function psb_c_zvect_get_nrows(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_zvect_get_nrows(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh type(psb_z_vect_type), pointer :: vp @@ -19,27 +19,27 @@ contains res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) res = vp%get_nrows() end if end function psb_c_zvect_get_nrows - - function psb_c_zvect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_zvect_f_get_cpy(v,xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res complex(c_double_complex) :: v(*) type(psb_c_zvector) :: xh - + type(psb_z_vect_type), pointer :: vp complex(psb_dpk_), allocatable :: fv(:) integer(psb_c_ipk_) :: info, sz res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) fv = vp%get_vect() sz = size(fv) @@ -48,31 +48,49 @@ contains end function psb_c_zvect_f_get_cpy - - function psb_c_zvect_zero(xh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res + function psb_c_zvect_zero(xh) bind(c) result(res) + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_zvector) :: xh - + type(psb_z_vect_type), pointer :: vp integer(psb_c_ipk_) :: info res = -1 - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) call vp%zero() end if end function psb_c_zvect_zero - + function psb_c_zvect_f_get_pnt(xh) bind(c) result(res) + implicit none + + type(c_ptr) :: res + type(psb_c_zvector) :: xh + + type(psb_z_vect_type), pointer :: vp + + res = c_null_ptr + + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,vp) + if(vp%is_dev()) call vp%sync() + res = c_loc(vp%v%v) + end if + + end function psb_c_zvect_f_get_pnt + + function psb_c_zmat_get_nrows(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh @@ -80,22 +98,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_nrows() end function psb_c_zmat_get_nrows - + function psb_c_zmat_get_ncols(mh) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_zspmat) :: mh @@ -103,22 +121,22 @@ contains integer(psb_c_ipk_) :: info res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if - + res = ap%get_ncols() end function psb_c_zmat_get_ncols - + function psb_c_zmat_name_print(mh,name) bind(c) result(res) use psb_base_mod use psb_objhandle_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res character(c_char) :: name(*) @@ -128,17 +146,16 @@ contains character(1024) :: fname res = 0 - if (c_associated(mh%item)) then + if (c_associated(mh%item)) then call c_f_pointer(mh%item,ap) else - return + return end if call stringc2f(name,fname) - + call ap%print(fname,head='PSBLAS Cbinding Interface') end function psb_c_zmat_name_print - + end module psb_z_serial_cbind_mod - diff --git a/cbind/util/Makefile b/cbind/util/Makefile new file mode 100644 index 000000000..d37cb6807 --- /dev/null +++ b/cbind/util/Makefile @@ -0,0 +1,34 @@ +TOP=../.. +include $(TOP)/Make.inc +LIBDIR=$(TOP)/lib +INCLUDEDIR=$(TOP)/include +MODDIR=$(TOP)/modules +HERE=.. + +FINCLUDES=$(FMFLAG). $(FMFLAG)$(HERE) $(FMFLAG)$(MODDIR) +CINCLUDES=-I. -I$(HERE) -I$(INCLUDEDIR) + +OBJS=psb_util_cbind_mod.o \ +psb_c_util_cbind_mod.o \ +psb_d_util_cbind_mod.o \ +psb_s_util_cbind_mod.o \ +psb_z_util_cbind_mod.o +CMOD=psb_util_cbind.h psb_c_cutil.h psb_c_zutil.h psb_c_dutil.h psb_c_sutil.h + +LIBNAME=$(CUTILLIBNAME) + + +lib: $(OBJS) $(CMOD) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + /bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR) + /bin/cp -p *$(.mod) $(CMOD) $(HERE) + +psb_util_cbind_mod.o: psb_c_util_cbind_mod.o psb_d_util_cbind_mod.o psb_s_util_cbind_mod.o psb_z_util_cbind_mod.o +veryclean: clean + /bin/rm -f $(HERE)/$(LIBNAME) + +clean: + /bin/rm -f $(OBJS) *$(.mod) + +veryclean: clean diff --git a/cbind/util/psb_c_cutil.h b/cbind/util/psb_c_cutil.h new file mode 100644 index 000000000..4d2755d6b --- /dev/null +++ b/cbind/util/psb_c_cutil.h @@ -0,0 +1,16 @@ +#ifndef PSB_C_CUTIL_ +#define PSB_C_CUTIL_ +#include "psb_base_cbind.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* I/O Routine */ +psb_i_t psb_c_cmm_mat_write(psb_c_cspmat *ah, char *matrixtitle, char *filename); + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif diff --git a/cbind/util/psb_c_dutil.h b/cbind/util/psb_c_dutil.h new file mode 100644 index 000000000..306d73104 --- /dev/null +++ b/cbind/util/psb_c_dutil.h @@ -0,0 +1,16 @@ +#ifndef PSB_C_DUTIL_ +#define PSB_C_DUTIL_ +#include "psb_base_cbind.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* I/O Routine */ +psb_i_t psb_c_dmm_mat_write(psb_c_dspmat *ah, char *matrixtitle, char *filename); + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif diff --git a/cbind/util/psb_c_sutil.h b/cbind/util/psb_c_sutil.h new file mode 100644 index 000000000..9dd1ed54f --- /dev/null +++ b/cbind/util/psb_c_sutil.h @@ -0,0 +1,16 @@ +#ifndef PSB_C_SUTIL_ +#define PSB_C_SUTIL_ +#include "psb_base_cbind.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* I/O Routine */ +psb_i_t psb_c_smm_mat_write(psb_c_sspmat *ah, char *matrixtitle, char *filename); + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif diff --git a/cbind/util/psb_c_util_cbind_mod.f90 b/cbind/util/psb_c_util_cbind_mod.f90 new file mode 100644 index 000000000..3761cd082 --- /dev/null +++ b/cbind/util/psb_c_util_cbind_mod.f90 @@ -0,0 +1,44 @@ +module psb_cutil_cbind_mod + + use iso_c_binding + use psb_util_mod + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + +contains + + function psb_c_cmm_mat_write(ah,matrixtitle,filename) bind(c) result(res) + use psb_base_mod + use psb_util_mod + use psb_base_string_cbind_mod + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cspmat) :: ah + character(c_char) :: matrixtitle(*) + character(c_char) :: filename(*) + + type(psb_cspmat_type), pointer :: ap + character(len=1024) :: mtitle + character(len=1024) :: fname + integer(psb_c_ipk_) :: info + + + res = -1 + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call stringc2f(matrixtitle,mtitle) + call stringc2f(filename,fname) + + call mm_mat_write(ap,mtitle,info,filename=fname) + + res = info + + end function psb_c_cmm_mat_write + +end module psb_cutil_cbind_mod diff --git a/cbind/util/psb_c_zutil.h b/cbind/util/psb_c_zutil.h new file mode 100644 index 000000000..f5d0f2258 --- /dev/null +++ b/cbind/util/psb_c_zutil.h @@ -0,0 +1,16 @@ +#ifndef PSB_C_ZUTIL_ +#define PSB_C_ZUTIL_ +#include "psb_base_cbind.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* I/O Routine */ +psb_i_t psb_c_zmm_mat_write(psb_c_zspmat *ah, char *matrixtitle, char *filename); + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif diff --git a/cbind/util/psb_d_util_cbind_mod.f90 b/cbind/util/psb_d_util_cbind_mod.f90 new file mode 100644 index 000000000..245cff5e8 --- /dev/null +++ b/cbind/util/psb_d_util_cbind_mod.f90 @@ -0,0 +1,44 @@ +module psb_dutil_cbind_mod + + use iso_c_binding + use psb_util_mod + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + +contains + + function psb_c_dmm_mat_write(ah,matrixtitle,filename) bind(c) result(res) + use psb_base_mod + use psb_util_mod + use psb_base_string_cbind_mod + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dspmat) :: ah + character(c_char) :: matrixtitle(*) + character(c_char) :: filename(*) + + type(psb_dspmat_type), pointer :: ap + character(len=1024) :: mtitle + character(len=1024) :: fname + integer(psb_c_ipk_) :: info + + + res = -1 + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call stringc2f(matrixtitle,mtitle) + call stringc2f(filename,fname) + + call mm_mat_write(ap,mtitle,info,filename=fname) + + res = info + + end function psb_c_dmm_mat_write + +end module psb_dutil_cbind_mod diff --git a/cbind/util/psb_s_util_cbind_mod.f90 b/cbind/util/psb_s_util_cbind_mod.f90 new file mode 100644 index 000000000..e857cde9a --- /dev/null +++ b/cbind/util/psb_s_util_cbind_mod.f90 @@ -0,0 +1,44 @@ +module psb_sutil_cbind_mod + + use iso_c_binding + use psb_util_mod + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + +contains + + function psb_c_smm_mat_write(ah,matrixtitle,filename) bind(c) result(res) + use psb_base_mod + use psb_util_mod + use psb_base_string_cbind_mod + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_sspmat) :: ah + character(c_char) :: matrixtitle(*) + character(c_char) :: filename(*) + + type(psb_sspmat_type), pointer :: ap + character(len=1024) :: mtitle + character(len=1024) :: fname + integer(psb_c_ipk_) :: info + + + res = -1 + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call stringc2f(matrixtitle,mtitle) + call stringc2f(filename,fname) + + call mm_mat_write(ap,mtitle,info,filename=fname) + + res = info + + end function psb_c_smm_mat_write + +end module psb_sutil_cbind_mod diff --git a/cbind/util/psb_util_cbind.h b/cbind/util/psb_util_cbind.h new file mode 100644 index 000000000..4179b3b1c --- /dev/null +++ b/cbind/util/psb_util_cbind.h @@ -0,0 +1,10 @@ +#ifndef PSB_UTIL_CBIND_ +#define PSB_UTIL_CBIND_ + +#include "psb_c_sutil.h" +#include "psb_c_dutil.h" +#include "psb_c_cutil.h" +#include "psb_c_zutil.h" + + +#endif diff --git a/cbind/util/psb_util_cbind_mod.f90 b/cbind/util/psb_util_cbind_mod.f90 new file mode 100644 index 000000000..96bafe4ac --- /dev/null +++ b/cbind/util/psb_util_cbind_mod.f90 @@ -0,0 +1,6 @@ +module psb_base_util_cbind_mod + use psb_cutil_cbind_mod + use psb_dutil_cbind_mod + use psb_sutil_cbind_mod + use psb_zutil_cbind_mod +end module psb_base_util_cbind_mod diff --git a/cbind/util/psb_z_util_cbind_mod.f90 b/cbind/util/psb_z_util_cbind_mod.f90 new file mode 100644 index 000000000..e0b60005c --- /dev/null +++ b/cbind/util/psb_z_util_cbind_mod.f90 @@ -0,0 +1,44 @@ +module psb_zutil_cbind_mod + + use iso_c_binding + use psb_util_mod + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod + +contains + + function psb_c_zmm_mat_write(ah,matrixtitle,filename) bind(c) result(res) + use psb_base_mod + use psb_util_mod + use psb_base_string_cbind_mod + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zspmat) :: ah + character(c_char) :: matrixtitle(*) + character(c_char) :: filename(*) + + type(psb_zspmat_type), pointer :: ap + character(len=1024) :: mtitle + character(len=1024) :: fname + integer(psb_c_ipk_) :: info + + + res = -1 + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + call stringc2f(matrixtitle,mtitle) + call stringc2f(filename,fname) + + call mm_mat_write(ap,mtitle,info,filename=fname) + + res = info + + end function psb_c_zmm_mat_write + +end module psb_zutil_cbind_mod diff --git a/docs/psblas-3.7.pdf b/docs/psblas-3.7.pdf index 8596f10a0..e42d4f141 100644 --- a/docs/psblas-3.7.pdf +++ b/docs/psblas-3.7.pdf @@ -30137,8 +30137,18 @@ endobj 2131 0 obj << /Title (Parallel Sparse BLAS V. 3.7.0) /Subject (Parallel Sparse Basic Linear Algebra Subroutines) /Keywords (Computer Science Linear Algebra Fluid Dynamics Parallel Linux MPI PSBLAS Iterative Solvers Preconditioners) /Creator (pdfLaTeX) /Producer ($Id$) /Author()/Title()/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.19)/Keywords() +<<<<<<< HEAD /CreationDate (D:20200425083929+02'00') /ModDate (D:20200425083929+02'00') +======= +<<<<<<< HEAD +/CreationDate (D:20191217194209Z) +/ModDate (D:20191217194209Z) +======= +/CreationDate (D:20191218141557Z) +/ModDate (D:20191218141557Z) +>>>>>>> unify_aggr_bld +>>>>>>> merge-paraggr-newops /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.19 (TeX Live 2018) kpathsea version 6.3.0) >> @@ -30271,10 +30281,17 @@ endobj /Index [0 2133] /Size 2133 /W [1 3 1] +<<<<<<< HEAD +/Root 2129 0 R +/Info 2130 0 R +/ID [<362C1AAB92CF66A0E508C639DC7E96C3> <362C1AAB92CF66A0E508C639DC7E96C3>] +/Length 10660 +======= /Root 2130 0 R /Info 2131 0 R /ID [ ] /Length 10665 +>>>>>>> unify_aggr_bld >> stream ÿ”ZÛéIÛéSÛé[Úc@Úb  diff --git a/docs/src/userguide.pdf b/docs/src/userguide.pdf new file mode 120000 index 000000000..7b032aa3e --- /dev/null +++ b/docs/src/userguide.pdf @@ -0,0 +1 @@ +tmp/userguide.pdf \ No newline at end of file diff --git a/test/kernel/Makefile b/test/kernel/Makefile index 8eb076a49..9dc88e59a 100644 --- a/test/kernel/Makefile +++ b/test/kernel/Makefile @@ -12,36 +12,38 @@ LDLIBS=$(PSBLDLIBS) FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). -DTOBJS=d_file_spmv.o -STOBJS=s_file_spmv.o +DTOBJS=d_file_spmv.o +STOBJS=s_file_spmv.o DPGOBJS=pdgenspmv.o +DVECOBJS=vecoperation.o EXEDIR=./runs -all: runsd d_file_spmv s_file_spmv pdgenspmv +all: runsd d_file_spmv s_file_spmv pdgenspmv vecoperation runsd: (if test ! -d runs ; then mkdir runs; fi) d_file_spmv: $(DTOBJS) - $(FLINK) $(LOPT) $(DTOBJS) -o d_file_spmv $(PSBLAS_LIB) $(LDLIBS) - /bin/mv d_file_spmv $(EXEDIR) + $(FLINK) $(LOPT) $(DTOBJS) -o d_file_spmv $(PSBLAS_LIB) $(LDLIBS) + /bin/mv d_file_spmv $(EXEDIR) pdgenspmv: $(DPGOBJS) - $(FLINK) $(LOPT) $(DPGOBJS) -o pdgenspmv $(PSBLAS_LIB) $(LDLIBS) - /bin/mv pdgenspmv $(EXEDIR) + $(FLINK) $(LOPT) $(DPGOBJS) -o pdgenspmv $(PSBLAS_LIB) $(LDLIBS) + /bin/mv pdgenspmv $(EXEDIR) s_file_spmv: $(STOBJS) - $(FLINK) $(LOPT) $(STOBJS) -o s_file_spmv $(PSBLAS_LIB) $(LDLIBS) - /bin/mv s_file_spmv $(EXEDIR) + $(FLINK) $(LOPT) $(STOBJS) -o s_file_spmv $(PSBLAS_LIB) $(LDLIBS) + /bin/mv s_file_spmv $(EXEDIR) +vecoperation: $(DVECOBJS) + $(FLINK) $(LOPT) $(DVECOBJS) -o vecoperation $(PSBLAS_LIB) $(LDLIBS) + /bin/mv vecoperation $(EXEDIR) - -clean: - /bin/rm -f $(DBOBJSS) $(DBOBJS) $(DTOBJS) $(STOBJS) +clean: + /bin/rm -f $(DBOBJSS) $(DBOBJS) $(DTOBJS) $(STOBJS) $(DVECOBJS) lib: (cd ../../; make library) verycleanlib: (cd ../../; make veryclean) - diff --git a/test/kernel/vecoperation.f90 b/test/kernel/vecoperation.f90 new file mode 100644 index 000000000..0b73ff15c --- /dev/null +++ b/test/kernel/vecoperation.f90 @@ -0,0 +1,383 @@ +! +! Parallel Sparse BLAS version 3.5.1 +! (C) Copyright 2015 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: vecoperation.f90 +! +module unittestvector_mod + + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_desc_type,& + & psb_dspmat_type, psb_d_vect_type, dzero,& + & psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type + + interface psb_gen_const + module procedure psb_d_gen_const + end interface psb_gen_const + +contains + + function psb_check_ans(v,val,ictxt) result(ans) + use psb_base_mod + + implicit none + + type(psb_d_vect_type) :: v + real(psb_dpk_) :: val + integer(psb_ipk_) :: ictxt + logical :: ans + + ! Local variables + integer(psb_ipk_) :: np, iam, info + real(psb_dpk_) :: check + real(psb_dpk_), allocatable :: va(:) + + call psb_info(ictxt,iam,np) + + va = v%get_vect() + va = va - val; + + check = maxval(va); + + call psb_sum(ictxt,check) + + if(check == 0.d0) then + ans = .true. + else + ans = .false. + end if + + end function psb_check_ans + ! + ! subroutine to fill a vector with constant entries + ! + subroutine psb_d_gen_const(v,val,idim,ictxt,desc_a,info) + use psb_base_mod + implicit none + + type(psb_d_vect_type) :: v + type(psb_desc_type) :: desc_a + integer(psb_lpk_) :: idim + integer(psb_ipk_) :: ictxt, info + real(psb_dpk_) :: val + + ! Local variables + integer(psb_ipk_), parameter :: nb=20 + real(psb_dpk_) :: zt(nb) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: np, iam, nr, nt + integer(psb_ipk_) :: n,nlr,ib,ii + integer(psb_ipk_) :: err_act + integer(psb_lpk_), allocatable :: myidx(:) + + + info = psb_success_ + name = 'create_constant_vector' + call psb_erractionsave(err_act) + + call psb_info(ictxt, iam, np) + + n = idim*np ! The global dimension is the number of process times + ! the input size + + ! We use a simple minded block distribution + nt = (n+np-1)/np + nr = max(0,min(nt,n-(iam*nt))) + nt = nr + + call psb_sum(ictxt,nt) + if (nt /= n) then + write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,n + info = -1 + call psb_barrier(ictxt) + call psb_abort(ictxt) + return + end if + ! Allocate the descriptor with simple minded data distribution + call psb_cdall(ictxt,desc_a,info,nl=nr) + ! Allocate the vector on the recently build descriptor + if (info == psb_success_) call psb_geall(v,desc_a,info) + ! Check that allocation has gone good + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + do ii=1,nlr,nb + ib = min(nb,nlr-ii+1) + zt(:) = val + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),v,desc_a,info) + if(info /= psb_success_) exit + end do + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='insert rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! Assembly of communicator and vector + call psb_cdasb(desc_a,info) + if (info == psb_success_) call psb_geasb(v,desc_a,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psb_d_gen_const + +end module unittestvector_mod + + +program vecoperation + use psb_base_mod + use psb_util_mod + use unittestvector_mod + implicit none + + ! input parameters + integer(psb_lpk_) :: idim = 100 + + ! miscellaneous + real(psb_dpk_), parameter :: one = 1.d0 + real(psb_dpk_), parameter :: two = 2.d0 + real(psb_dpk_), parameter :: onehalf = 0.5_psb_dpk_ + real(psb_dpk_), parameter :: negativeone = -1.d0 + real(psb_dpk_), parameter :: negativetwo = -2.d0 + real(psb_dpk_), parameter :: negativeonehalf = -0.5_psb_dpk_ + ! descriptor + type(psb_desc_type) :: desc_a + ! vector + type(psb_d_vect_type) :: x,y,z + ! blacs parameters + integer(psb_ipk_) :: ictxt, iam, np + ! auxiliary parameters + integer(psb_ipk_) :: info + character(len=20) :: name,ch_err,readinput + real(psb_dpk_) :: ans + logical :: hasitnotfailed + integer(psb_lpk_), allocatable :: myidx(:) + integer(psb_ipk_) :: ib = 1 + real(psb_dpk_) :: zt(1) + + info=psb_success_ + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + call psb_exit(ictxt) ! This should not happen, but just in case + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='vecoperation' + call psb_set_errverbosity(itwo) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + end if + + call get_command_argument(1,readinput) + if (len_trim(readinput) /= 0) read(readinput,*)idim + + if (iam == psb_root_) write(psb_out_unit,'(" ")') + if (iam == psb_root_) write(psb_out_unit,'("Local vector size",I10)')idim + if (iam == psb_root_) write(psb_out_unit,'("Global vector size",I10)')np*idim + + ! + ! Test of standard vector operation + ! + if (iam == psb_root_) write(psb_out_unit,'(" ")') + if (iam == psb_root_) write(psb_out_unit,'("Standard Vector Operations")') + if (iam == psb_root_) write(psb_out_unit,'(" ")') + ! X = 1 + call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) + hasitnotfailed = psb_check_ans(x,one,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> Constant vector ")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- Constant vector ")') + end if + ! X = 1 , Y = -2, Y = X + Y = 1 -2 = -1 + call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,negativetwo,idim,ictxt,desc_a,info) + call psb_geaxpby(one,x,one,y,desc_a,info) + hasitnotfailed = psb_check_ans(y,negativeone,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = X + Y ")') + end if + ! X = 1 , Y = 2, Y = -X + Y = -1 +2 = 1 + call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,two,idim,ictxt,desc_a,info) + call psb_geaxpby(negativeone,x,one,y,desc_a,info) + hasitnotfailed = psb_check_ans(y,one,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = -X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = -X + Y ")') + end if + ! X = 2 , Y = -2, Y = 0.5*X + Y = 1 - 2 = -1 + call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,negativetwo,idim,ictxt,desc_a,info) + call psb_geaxpby(onehalf,x,one,y,desc_a,info) + hasitnotfailed = psb_check_ans(y,negativeone,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Y = 0.5 X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Y = 0.5 X + Y ")') + end if + ! X = -2 , Y = 1, Z = 0, Z = X + Y = -2 + 1 = -1 + call psb_d_gen_const(x,negativetwo,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_geaxpby(one,x,one,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = X + Y ")') + end if + ! X = 2 , Y = 1, Z = 0, Z = X - Y = 2 - 1 = 1 + call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_geaxpby(one,x,negativeone,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,one,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = X - Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = X - Y ")') + end if + ! X = 2 , Y = 1, Z = 0, Z = -X + Y = -2 + 1 = -1 + call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_geaxpby(negativeone,x,one,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> axpby Z = -X + Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- axpby Z = -X + Y ")') + end if + ! X = 2 , Y = -0.5, Z = 0, Z = X*Y = 2*(-0.5) = -1 + call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,negativeonehalf,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_gemlt(one,x,y,dzero,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> mlt Z = X*Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- mlt Z = X*Y ")') + end if + ! X = 1 , Y = 2, Z = 0, Z = X/Y = 1/2 = 0.5 + call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_gediv(x,y,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,onehalf,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> div Z = X/Y")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- div Z = X/Y ")') + end if + ! X = -1 , Z = 0, Z = |X| = |-1| = 1 + call psb_d_gen_const(x,negativeone,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_geabs(x,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,one,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> abs Z = |X|")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- abs Z = |X| ")') + end if + ! X = 2 , Z = 0, Z = 1/X = 1/2 = 0.5 + call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_geinv(x,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,onehalf,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> inv Z = 1/X")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- inv Z = 1/X ")') + end if + ! X = 1, Z = 0, c = -2, Z = X + c = -1 + call psb_d_gen_const(x,one,idim,ictxt,desc_a,info) + call psb_d_gen_const(z,dzero,idim,ictxt,desc_a,info) + call psb_geaddconst(x,negativetwo,z,desc_a,info) + hasitnotfailed = psb_check_ans(z,negativeone,ictxt) + if (iam == psb_root_) then + if(hasitnotfailed) write(psb_out_unit,'("TEST PASSED >>> Add constant Z = X + c")') + if(.not.hasitnotfailed) write(psb_out_unit,'("TEST FAILED --- Add constant Z = X + c")') + end if + + ! + ! Vector to field operation + ! + if (iam == psb_root_) write(psb_out_unit,'(" ")') + if (iam == psb_root_) write(psb_out_unit,'("Vector to Field Operations")') + if (iam == psb_root_) write(psb_out_unit,'(" ")') + + ! Dot product + call psb_d_gen_const(x,two,idim,ictxt,desc_a,info) + call psb_d_gen_const(y,onehalf,idim,ictxt,desc_a,info) + ans = psb_gedot(x,y,desc_a,info) + if (iam == psb_root_) then + if(ans == np*idim) write(psb_out_unit,'("TEST PASSED >>> Dot product")') + if(ans /= np*idim) write(psb_out_unit,'("TEST FAILED --- Dot product")') + end if + ! MaxNorm + call psb_d_gen_const(x,negativeonehalf,idim,ictxt,desc_a,info) + ans = psb_geamax(x,desc_a,info) + if (iam == psb_root_) then + if(ans == onehalf) write(psb_out_unit,'("TEST PASSED >>> MaxNorm")') + if(ans /= onehalf) write(psb_out_unit,'("TEST FAILED --- MaxNorm")') + end if + + call psb_gefree(x,desc_a,info) + call psb_gefree(y,desc_a,info) + call psb_gefree(z,desc_a,info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + + call psb_exit(ictxt) + stop + +9999 call psb_error(ictxt) + + stop +end program vecoperation