From c4cf78e7b8a446363fb39f0e71d471d98e9046b3 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Mon, 6 Apr 2020 13:50:48 +0200 Subject: [PATCH] Added interface (and C interface) to is_upd() for sparse matrices --- base/modules/psblas/psb_c_psblas_mod.F90 | 11 +++++ base/modules/psblas/psb_d_psblas_mod.F90 | 11 +++++ base/modules/psblas/psb_s_psblas_mod.F90 | 11 +++++ base/modules/psblas/psb_z_psblas_mod.F90 | 11 +++++ base/psblas/psb_cgetmatinfo.f90 | 56 +++++++++++++++++++++++- base/psblas/psb_dgetmatinfo.f90 | 56 +++++++++++++++++++++++- base/psblas/psb_sgetmatinfo.f90 | 56 +++++++++++++++++++++++- base/psblas/psb_zgetmatinfo.f90 | 56 +++++++++++++++++++++++- cbind/base/psb_c_cbase.h | 1 + cbind/base/psb_c_dbase.h | 1 + cbind/base/psb_c_psblas_cbind_mod.f90 | 24 ++++++++++ cbind/base/psb_c_sbase.h | 1 + cbind/base/psb_c_zbase.h | 1 + cbind/base/psb_d_psblas_cbind_mod.f90 | 24 ++++++++++ cbind/base/psb_s_psblas_cbind_mod.f90 | 24 ++++++++++ cbind/base/psb_z_psblas_cbind_mod.f90 | 24 ++++++++++ 16 files changed, 364 insertions(+), 4 deletions(-) diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index 56ea620a..05c0b895 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -599,4 +599,15 @@ module psb_c_psblas_mod 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 + 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 2c0ea438..165ee4c1 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -634,4 +634,15 @@ module psb_d_psblas_mod 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 + 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 8b9a21c0..d1b04e75 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -634,4 +634,15 @@ module psb_s_psblas_mod 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 + 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 279c28ba..e16a4060 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -599,4 +599,15 @@ module psb_z_psblas_mod 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 + end module psb_z_psblas_mod diff --git a/base/psblas/psb_cgetmatinfo.f90 b/base/psblas/psb_cgetmatinfo.f90 index 43bd7ea5..e2516d04 100644 --- a/base/psblas/psb_cgetmatinfo.f90 +++ b/base/psblas/psb_cgetmatinfo.f90 @@ -52,7 +52,7 @@ function psb_cget_nnz(a,desc_a,info) result(res) integer(psb_lpk_) :: m,n,ia,ja,localnnz character(len=20) :: name, ch_err ! - name='psb_cspmv' + name='psb_cget_nnz' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -90,3 +90,57 @@ function psb_cget_nnz(a,desc_a,info) result(res) return end function + +function psb_c_is_matupd(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_c_is_matupd + use psi_mod + + implicit none + + logical :: 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_) :: m,n,ia,ja,localnnz + character(len=20) :: name, ch_err + ! + name='psb_cis_matupd' + 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 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + ! Check for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + res = a%is_upd() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_dgetmatinfo.f90 b/base/psblas/psb_dgetmatinfo.f90 index 39f4e539..031ad63c 100644 --- a/base/psblas/psb_dgetmatinfo.f90 +++ b/base/psblas/psb_dgetmatinfo.f90 @@ -52,7 +52,7 @@ function psb_dget_nnz(a,desc_a,info) result(res) integer(psb_lpk_) :: m,n,ia,ja,localnnz character(len=20) :: name, ch_err ! - name='psb_dspmv' + name='psb_dget_nnz' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -90,3 +90,57 @@ function psb_dget_nnz(a,desc_a,info) result(res) return end function + +function psb_d_is_matupd(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_d_is_matupd + use psi_mod + + implicit none + + logical :: 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_) :: m,n,ia,ja,localnnz + character(len=20) :: name, ch_err + ! + name='psb_dis_matupd' + 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 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + ! Check for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + res = a%is_upd() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_sgetmatinfo.f90 b/base/psblas/psb_sgetmatinfo.f90 index f5593eaa..a9a4d132 100644 --- a/base/psblas/psb_sgetmatinfo.f90 +++ b/base/psblas/psb_sgetmatinfo.f90 @@ -52,7 +52,7 @@ function psb_sget_nnz(a,desc_a,info) result(res) integer(psb_lpk_) :: m,n,ia,ja,localnnz character(len=20) :: name, ch_err ! - name='psb_sspmv' + name='psb_sget_nnz' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -90,3 +90,57 @@ function psb_sget_nnz(a,desc_a,info) result(res) return end function + +function psb_s_is_matupd(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_s_is_matupd + use psi_mod + + implicit none + + logical :: 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_) :: m,n,ia,ja,localnnz + character(len=20) :: name, ch_err + ! + name='psb_sis_matupd' + 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 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + ! Check for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + res = a%is_upd() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/base/psblas/psb_zgetmatinfo.f90 b/base/psblas/psb_zgetmatinfo.f90 index 76904239..6d1ec857 100644 --- a/base/psblas/psb_zgetmatinfo.f90 +++ b/base/psblas/psb_zgetmatinfo.f90 @@ -52,7 +52,7 @@ function psb_zget_nnz(a,desc_a,info) result(res) integer(psb_lpk_) :: m,n,ia,ja,localnnz character(len=20) :: name, ch_err ! - name='psb_zspmv' + name='psb_zget_nnz' info=psb_success_ call psb_erractionsave(err_act) if (psb_errstatus_fatal()) then @@ -90,3 +90,57 @@ function psb_zget_nnz(a,desc_a,info) result(res) return end function + +function psb_z_is_matupd(a,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_z_is_matupd + use psi_mod + + implicit none + + logical :: 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_) :: m,n,ia,ja,localnnz + character(len=20) :: name, ch_err + ! + name='psb_zis_matupd' + 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 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + ! Check for matrix correctness + call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkmat' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + res = a%is_upd() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end function diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 4f4e5bb3..0c76df49 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -41,6 +41,7 @@ psb_i_t psb_c_cspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, 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); /* 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); */ diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index 15a5ab15..3c3ac712 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -41,6 +41,7 @@ psb_i_t psb_c_dspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, 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); /* 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); */ diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index d52d4140..dfd9dde1 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -897,5 +897,29 @@ contains end function psb_c_cnnz + function psb_c_cis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical :: 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 + + 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_is_matupd(ap,descp,info) + end function end module psb_c_psblas_cbind_mod diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index e9827fec..2bd285b2 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -41,6 +41,7 @@ psb_i_t psb_c_sspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, 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); /* 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); */ diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 090e2544..94cf0209 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -41,6 +41,7 @@ psb_i_t psb_c_zspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, 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); /* 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); */ diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 49ef0278..09f7e595 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -998,5 +998,29 @@ contains end function psb_c_dnnz + function psb_c_dis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical :: 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 + + 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_is_matupd(ap,descp,info) + end function end module psb_d_psblas_cbind_mod diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index 76f85010..92b76b2f 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -998,5 +998,29 @@ contains end function psb_c_snnz + function psb_c_sis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical :: 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 + + 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_is_matupd(ap,descp,info) + end function end module psb_s_psblas_cbind_mod diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index 91ca0f55..d9cc0e50 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -897,5 +897,29 @@ contains end function psb_c_znnz + function psb_c_zis_matupd(ah,cdh) bind(c) result(res) + implicit none + logical :: 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 + + 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_is_matupd(ap,descp,info) + end function end module psb_z_psblas_cbind_mod