diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index b7c8d02f..94c1cf49 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -643,6 +643,17 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswapdatav + +! +! +! Subroutine: psi_cswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidxv @@ -998,6 +1009,15 @@ subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_cswapidxv +! +! +! Subroutine: psi_cswapdata_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +! subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_cswapdata_vect @@ -1072,6 +1092,19 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswapdata_vect +! +! +! Subroutine: psi_cswapidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswapidx_vect @@ -1430,6 +1463,19 @@ subroutine psi_cswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, end subroutine psi_cswapidx_vect + +! +! +! Subroutine: psi_cswapvidx_vect +! Data exchange among processes. +! +! Case where the index vector is also encapsulated. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_cswap_vidx_vect diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 0bb052db..65bfa6b2 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -653,6 +653,17 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswaptranv +! +! +! Subroutine: psi_ctranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! + subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -1025,6 +1036,16 @@ subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end subroutine psi_ctranidxv +! +! +! +! +! Subroutine: psi_cswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_cswaptran_vect diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 1935f12a..9ddc32c9 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -643,6 +643,17 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswapdatav + +! +! +! Subroutine: psi_dswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidxv @@ -998,6 +1009,15 @@ subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_dswapidxv +! +! +! Subroutine: psi_dswapdata_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +! subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_dswapdata_vect @@ -1072,6 +1092,19 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswapdata_vect +! +! +! Subroutine: psi_dswapidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswapidx_vect @@ -1430,6 +1463,19 @@ subroutine psi_dswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, end subroutine psi_dswapidx_vect + +! +! +! Subroutine: psi_dswapvidx_vect +! Data exchange among processes. +! +! Case where the index vector is also encapsulated. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_dswap_vidx_vect diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 2dfc204b..4c514f48 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -653,6 +653,17 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswaptranv +! +! +! Subroutine: psi_dtranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! + subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -1025,6 +1036,16 @@ subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end subroutine psi_dtranidxv +! +! +! +! +! Subroutine: psi_dswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_dswaptran_vect diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index fd7cd0c9..cb8cf3f8 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -643,6 +643,17 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswapdatav + +! +! +! Subroutine: psi_iswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswapidxv @@ -998,6 +1009,15 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_iswapidxv +! +! +! Subroutine: psi_iswapdata_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +! subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_iswapdata_vect @@ -1072,6 +1092,19 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswapdata_vect +! +! +! Subroutine: psi_iswapidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswapidx_vect @@ -1430,6 +1463,19 @@ subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, end subroutine psi_iswapidx_vect + +! +! +! Subroutine: psi_iswapvidx_vect +! Data exchange among processes. +! +! Case where the index vector is also encapsulated. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_iswap_vidx_vect diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index 9b50ae7c..18d98238 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -653,6 +653,17 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswaptranv +! +! +! Subroutine: psi_itranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! + subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -1025,6 +1036,16 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end subroutine psi_itranidxv +! +! +! +! +! Subroutine: psi_iswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_iswaptran_vect diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index 9f8d5000..3e60911c 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -643,6 +643,17 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswapdatav + +! +! +! Subroutine: psi_sswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidxv @@ -998,6 +1009,15 @@ subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_sswapidxv +! +! +! Subroutine: psi_sswapdata_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +! subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_sswapdata_vect @@ -1072,6 +1092,19 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswapdata_vect +! +! +! Subroutine: psi_sswapidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswapidx_vect @@ -1430,6 +1463,19 @@ subroutine psi_sswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, end subroutine psi_sswapidx_vect + +! +! +! Subroutine: psi_sswapvidx_vect +! Data exchange among processes. +! +! Case where the index vector is also encapsulated. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_sswap_vidx_vect diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index 26d391a5..d8cee644 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -653,6 +653,17 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswaptranv +! +! +! Subroutine: psi_stranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! + subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -1025,6 +1036,16 @@ subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end subroutine psi_stranidxv +! +! +! +! +! Subroutine: psi_sswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_sswaptran_vect diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 1234dbe4..7dfdef19 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -643,6 +643,17 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswapdatav + +! +! +! Subroutine: psi_zswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidxv @@ -998,6 +1009,15 @@ subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work return end subroutine psi_zswapidxv +! +! +! Subroutine: psi_zswapdata_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +! subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_zswapdata_vect @@ -1072,6 +1092,19 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswapdata_vect +! +! +! Subroutine: psi_zswapidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswapidx_vect @@ -1430,6 +1463,19 @@ subroutine psi_zswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv, end subroutine psi_zswapidx_vect + +! +! +! Subroutine: psi_zswapvidx_vect +! Data exchange among processes. +! +! Case where the index vector is also encapsulated. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) use psi_mod, psb_protect_name => psi_zswap_vidx_vect diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 5004aedd..272f0830 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -653,6 +653,17 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswaptranv +! +! +! Subroutine: psi_ztranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! + subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) @@ -1025,6 +1036,16 @@ subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work end subroutine psi_ztranidxv +! +! +! +! +! Subroutine: psi_zswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) use psi_mod, psb_protect_name => psi_zswaptran_vect diff --git a/base/modules/psb_c_base_mat_mod.f90 b/base/modules/psb_c_base_mat_mod.f90 index 7c564b3a..a032db7c 100644 --- a/base/modules/psb_c_base_mat_mod.f90 +++ b/base/modules/psb_c_base_mat_mod.f90 @@ -133,7 +133,7 @@ module psb_c_base_mat_mod !> Coefficient values. complex(psb_spk_), allocatable :: val(:) - integer, private :: sort_status=psb_unsorted_ + integer, private :: sort_status=psb_unsorted_ contains ! @@ -170,6 +170,7 @@ module psb_c_base_mat_mod procedure, pass(a) :: set_by_rows => c_coo_set_by_rows procedure, pass(a) :: set_by_cols => c_coo_set_by_cols procedure, pass(a) :: set_sort_status => c_coo_set_sort_status + procedure, pass(a) :: get_sort_status => c_coo_get_sort_status ! ! This is COO specific @@ -428,8 +429,8 @@ module psb_c_base_mat_mod subroutine psb_c_base_tril(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -469,8 +470,8 @@ module psb_c_base_mat_mod subroutine psb_c_base_triu(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -586,7 +587,7 @@ module psb_c_base_mat_mod subroutine psb_c_base_cp_from_coo(a,b,info) import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b + 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 @@ -656,7 +657,7 @@ module psb_c_base_mat_mod subroutine psb_c_base_mv_from_coo(a,b,info) import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ class(psb_c_base_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(inout) :: b + 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 @@ -1367,7 +1368,7 @@ module psb_c_base_mat_mod import :: psb_ipk_, psb_c_coo_sparse_mat class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_from_coo end interface @@ -1812,6 +1813,14 @@ contains end subroutine c_coo_set_nzeros + function c_coo_get_sort_status(a) result(res) + 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 integer(psb_ipk_), intent(in) :: ist diff --git a/base/modules/psb_c_csc_mat_mod.f90 b/base/modules/psb_c_csc_mat_mod.f90 index 72930360..ed5d1e44 100644 --- a/base/modules/psb_c_csc_mat_mod.f90 +++ b/base/modules/psb_c_csc_mat_mod.f90 @@ -186,7 +186,7 @@ module psb_c_csc_mat_mod import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_coo_sparse_mat class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csc_from_coo end interface diff --git a/base/modules/psb_c_csr_mat_mod.f90 b/base/modules/psb_c_csr_mat_mod.f90 index 4819eaf5..730eafa4 100644 --- a/base/modules/psb_c_csr_mat_mod.f90 +++ b/base/modules/psb_c_csr_mat_mod.f90 @@ -189,7 +189,7 @@ module psb_c_csr_mat_mod import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_coo_sparse_mat class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_csr_from_coo end interface diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 912f5982..4377cac0 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -89,10 +89,10 @@ module psb_const_mod ! ! Version ! - character(len=*), parameter :: psb_version_string_ = "3.3.1" + character(len=*), parameter :: psb_version_string_ = "3.3.2" integer(psb_ipk_), parameter :: psb_version_major_ = 3 integer(psb_ipk_), parameter :: psb_version_minor_ = 3 - integer(psb_ipk_), parameter :: psb_patchlevel_ = 1 + integer(psb_ipk_), parameter :: psb_patchlevel_ = 2 ! ! Handy & miscellaneous constants diff --git a/base/modules/psb_d_base_mat_mod.f90 b/base/modules/psb_d_base_mat_mod.f90 index b208b97e..ed60940f 100644 --- a/base/modules/psb_d_base_mat_mod.f90 +++ b/base/modules/psb_d_base_mat_mod.f90 @@ -133,7 +133,7 @@ module psb_d_base_mat_mod !> Coefficient values. real(psb_dpk_), allocatable :: val(:) - integer, private :: sort_status=psb_unsorted_ + integer, private :: sort_status=psb_unsorted_ contains ! @@ -170,6 +170,7 @@ module psb_d_base_mat_mod procedure, pass(a) :: set_by_rows => d_coo_set_by_rows procedure, pass(a) :: set_by_cols => d_coo_set_by_cols procedure, pass(a) :: set_sort_status => d_coo_set_sort_status + procedure, pass(a) :: get_sort_status => d_coo_get_sort_status ! ! This is COO specific @@ -428,8 +429,8 @@ module psb_d_base_mat_mod subroutine psb_d_base_tril(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -469,8 +470,8 @@ module psb_d_base_mat_mod subroutine psb_d_base_triu(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -586,7 +587,7 @@ module psb_d_base_mat_mod subroutine psb_d_base_cp_from_coo(a,b,info) import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b + 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 @@ -656,7 +657,7 @@ module psb_d_base_mat_mod subroutine psb_d_base_mv_from_coo(a,b,info) import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ class(psb_d_base_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(inout) :: b + 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 @@ -1367,7 +1368,7 @@ module psb_d_base_mat_mod import :: psb_ipk_, psb_d_coo_sparse_mat class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_from_coo end interface @@ -1812,6 +1813,14 @@ contains end subroutine d_coo_set_nzeros + function d_coo_get_sort_status(a) result(res) + 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 integer(psb_ipk_), intent(in) :: ist diff --git a/base/modules/psb_d_csc_mat_mod.f90 b/base/modules/psb_d_csc_mat_mod.f90 index 102afe30..559d9e4e 100644 --- a/base/modules/psb_d_csc_mat_mod.f90 +++ b/base/modules/psb_d_csc_mat_mod.f90 @@ -186,7 +186,7 @@ module psb_d_csc_mat_mod import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_coo_sparse_mat class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csc_from_coo end interface diff --git a/base/modules/psb_d_csr_mat_mod.f90 b/base/modules/psb_d_csr_mat_mod.f90 index bd16b958..de1c8955 100644 --- a/base/modules/psb_d_csr_mat_mod.f90 +++ b/base/modules/psb_d_csr_mat_mod.f90 @@ -189,7 +189,7 @@ module psb_d_csr_mat_mod import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_coo_sparse_mat class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_csr_from_coo end interface diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index ebdc1e50..7ac2516e 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -69,7 +69,7 @@ module psb_error_mod interface psb_error_handler subroutine psb_ser_error_handler(err_act) import :: psb_ipk_ - integer(psb_ipk_), intent(in) :: err_act + integer(psb_ipk_), intent(inout) :: err_act end subroutine psb_ser_error_handler subroutine psb_par_error_handler(ictxt,err_act) import :: psb_ipk_,psb_mpik_ diff --git a/base/modules/psb_s_base_mat_mod.f90 b/base/modules/psb_s_base_mat_mod.f90 index 377a168c..640d61e2 100644 --- a/base/modules/psb_s_base_mat_mod.f90 +++ b/base/modules/psb_s_base_mat_mod.f90 @@ -133,7 +133,7 @@ module psb_s_base_mat_mod !> Coefficient values. real(psb_spk_), allocatable :: val(:) - integer, private :: sort_status=psb_unsorted_ + integer, private :: sort_status=psb_unsorted_ contains ! @@ -170,6 +170,7 @@ module psb_s_base_mat_mod procedure, pass(a) :: set_by_rows => s_coo_set_by_rows procedure, pass(a) :: set_by_cols => s_coo_set_by_cols procedure, pass(a) :: set_sort_status => s_coo_set_sort_status + procedure, pass(a) :: get_sort_status => s_coo_get_sort_status ! ! This is COO specific @@ -428,8 +429,8 @@ module psb_s_base_mat_mod subroutine psb_s_base_tril(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -469,8 +470,8 @@ module psb_s_base_mat_mod subroutine psb_s_base_triu(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -586,7 +587,7 @@ module psb_s_base_mat_mod subroutine psb_s_base_cp_from_coo(a,b,info) import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b + 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 @@ -656,7 +657,7 @@ module psb_s_base_mat_mod subroutine psb_s_base_mv_from_coo(a,b,info) import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ class(psb_s_base_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(inout) :: b + 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 @@ -1367,7 +1368,7 @@ module psb_s_base_mat_mod import :: psb_ipk_, psb_s_coo_sparse_mat class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_from_coo end interface @@ -1812,6 +1813,14 @@ contains end subroutine s_coo_set_nzeros + function s_coo_get_sort_status(a) result(res) + 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 integer(psb_ipk_), intent(in) :: ist diff --git a/base/modules/psb_s_csc_mat_mod.f90 b/base/modules/psb_s_csc_mat_mod.f90 index b7850006..9616238d 100644 --- a/base/modules/psb_s_csc_mat_mod.f90 +++ b/base/modules/psb_s_csc_mat_mod.f90 @@ -186,7 +186,7 @@ module psb_s_csc_mat_mod import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_coo_sparse_mat class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csc_from_coo end interface diff --git a/base/modules/psb_s_csr_mat_mod.f90 b/base/modules/psb_s_csr_mat_mod.f90 index e9d3c63f..d1e14658 100644 --- a/base/modules/psb_s_csr_mat_mod.f90 +++ b/base/modules/psb_s_csr_mat_mod.f90 @@ -189,7 +189,7 @@ module psb_s_csr_mat_mod import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_coo_sparse_mat class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_csr_from_coo end interface diff --git a/base/modules/psb_z_base_mat_mod.f90 b/base/modules/psb_z_base_mat_mod.f90 index b900bb94..81727804 100644 --- a/base/modules/psb_z_base_mat_mod.f90 +++ b/base/modules/psb_z_base_mat_mod.f90 @@ -133,7 +133,7 @@ module psb_z_base_mat_mod !> Coefficient values. complex(psb_dpk_), allocatable :: val(:) - integer, private :: sort_status=psb_unsorted_ + integer, private :: sort_status=psb_unsorted_ contains ! @@ -170,6 +170,7 @@ module psb_z_base_mat_mod procedure, pass(a) :: set_by_rows => z_coo_set_by_rows procedure, pass(a) :: set_by_cols => z_coo_set_by_cols procedure, pass(a) :: set_sort_status => z_coo_set_sort_status + procedure, pass(a) :: get_sort_status => z_coo_get_sort_status ! ! This is COO specific @@ -428,8 +429,8 @@ module psb_z_base_mat_mod subroutine psb_z_base_tril(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -469,8 +470,8 @@ module psb_z_base_mat_mod subroutine psb_z_base_triu(a,b,info,diag,imin,imax,& & jmin,jmax,rscale,cscale) import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale @@ -586,7 +587,7 @@ module psb_z_base_mat_mod subroutine psb_z_base_cp_from_coo(a,b,info) import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b + 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 @@ -656,7 +657,7 @@ module psb_z_base_mat_mod subroutine psb_z_base_mv_from_coo(a,b,info) import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ class(psb_z_base_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(inout) :: b + 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 @@ -1367,7 +1368,7 @@ module psb_z_base_mat_mod import :: psb_ipk_, psb_z_coo_sparse_mat class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_from_coo end interface @@ -1812,6 +1813,14 @@ contains end subroutine z_coo_set_nzeros + function z_coo_get_sort_status(a) result(res) + 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 integer(psb_ipk_), intent(in) :: ist diff --git a/base/modules/psb_z_csc_mat_mod.f90 b/base/modules/psb_z_csc_mat_mod.f90 index 9eadcb19..ce06407f 100644 --- a/base/modules/psb_z_csc_mat_mod.f90 +++ b/base/modules/psb_z_csc_mat_mod.f90 @@ -186,7 +186,7 @@ module psb_z_csc_mat_mod import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_coo_sparse_mat class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csc_from_coo end interface diff --git a/base/modules/psb_z_csr_mat_mod.f90 b/base/modules/psb_z_csr_mat_mod.f90 index 0cb75281..20fde4c9 100644 --- a/base/modules/psb_z_csr_mat_mod.f90 +++ b/base/modules/psb_z_csr_mat_mod.f90 @@ -189,7 +189,7 @@ module psb_z_csr_mat_mod import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_coo_sparse_mat class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_csr_from_coo end interface diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index d08112f4..2d388290 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -113,9 +113,13 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - + select type(b) + type is (psb_c_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + 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_ call psb_errpush(info,name, a_err='to/from coo') @@ -151,9 +155,14 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) ! info = psb_success_ call psb_erractionsave(err_act) - - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select if (info /= psb_success_) then info = psb_err_from_subroutine_ @@ -267,8 +276,13 @@ subroutine psb_c_base_mv_to_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) + select type(b) + type is (psb_c_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select return @@ -293,9 +307,13 @@ subroutine psb_c_base_mv_from_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - + select type(b) + type is (psb_c_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select return end subroutine psb_c_base_mv_from_fmt diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index 37bbf080..55bcd171 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -466,7 +466,7 @@ function psb_c_coo_get_nz_row(idx,a) result(res) res = 0 nza = a%get_nzeros() - if (a%is_sorted()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. ip = psb_ibsrch(idx,nza,a%ia) if (ip /= -1) return @@ -580,7 +580,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) end if if (beta == czero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -594,7 +594,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m @@ -933,7 +933,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) end if if (beta == czero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -951,7 +951,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -1650,7 +1650,7 @@ function psb_c_coo_csnmi(a) result(res) res = szero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_sorted()) then + if (a%is_by_rows()) then i = 1 j = i res = szero @@ -2067,7 +2067,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2344,7 +2344,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2884,7 +2884,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat - + call b%set_sort_status(a%get_sort_status()) nz = a%get_nzeros() call b%set_nzeros(nz) call b%reallocate(nz) @@ -2894,7 +2894,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) b%val(1:nz) = a%val(1:nz) - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -2912,7 +2912,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_coo implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - class(psb_c_coo_sparse_mat), intent(in) :: b + class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2925,7 +2925,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat - + call a%set_sort_status(b%get_sort_status()) nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -2934,7 +2934,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) a%ja(1:nz) = b%ja(1:nz) a%val(1:nz) = b%val(1:nz) - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 @@ -3036,6 +3036,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_c_base_sparse_mat = a%psb_c_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia, b%ia) @@ -3043,7 +3044,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) call move_alloc(a%val, b%val) call a%free() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -3077,13 +3078,14 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_c_base_sparse_mat = b%psb_c_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) call a%set_nzeros(b%get_nzeros()) call move_alloc(b%ia , a%ia ) call move_alloc(b%ja , a%ja ) call move_alloc(b%val, a%val ) call b%free() - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index a30508ca..ddc93c5c 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2139,8 +2139,7 @@ subroutine psb_c_cp_csc_from_coo(a,b,info) class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - + integer(psb_ipk_), intent(out) :: info type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) !locals diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index ea69b2ea..a1982a62 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -2658,7 +2658,7 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) @@ -2667,13 +2667,13 @@ subroutine psb_c_cp_csr_from_coo(a,b,info) integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + character(len=20) :: name='c_cp_csr_from_coo' info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) 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 @@ -2871,7 +2871,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) return nr = b%get_nrows() diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index 716e4168..804372cc 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -113,9 +113,13 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - + select type(b) + type is (psb_d_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + 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_ call psb_errpush(info,name, a_err='to/from coo') @@ -151,9 +155,14 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) ! info = psb_success_ call psb_erractionsave(err_act) - - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select if (info /= psb_success_) then info = psb_err_from_subroutine_ @@ -267,8 +276,13 @@ subroutine psb_d_base_mv_to_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) + select type(b) + type is (psb_d_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select return @@ -293,9 +307,13 @@ subroutine psb_d_base_mv_from_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - + select type(b) + type is (psb_d_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select return end subroutine psb_d_base_mv_from_fmt diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 897c919f..fd874173 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -466,7 +466,7 @@ function psb_d_coo_get_nz_row(idx,a) result(res) res = 0 nza = a%get_nzeros() - if (a%is_sorted()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. ip = psb_ibsrch(idx,nza,a%ia) if (ip /= -1) return @@ -580,7 +580,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) end if if (beta == dzero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -594,7 +594,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m @@ -933,7 +933,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) end if if (beta == dzero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -951,7 +951,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -1650,7 +1650,7 @@ function psb_d_coo_csnmi(a) result(res) res = dzero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_sorted()) then + if (a%is_by_rows()) then i = 1 j = i res = dzero @@ -2067,7 +2067,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2344,7 +2344,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2884,7 +2884,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat - + call b%set_sort_status(a%get_sort_status()) nz = a%get_nzeros() call b%set_nzeros(nz) call b%reallocate(nz) @@ -2894,7 +2894,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) b%val(1:nz) = a%val(1:nz) - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -2912,7 +2912,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_coo implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - class(psb_d_coo_sparse_mat), intent(in) :: b + class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2925,7 +2925,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat - + call a%set_sort_status(b%get_sort_status()) nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -2934,7 +2934,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) a%ja(1:nz) = b%ja(1:nz) a%val(1:nz) = b%val(1:nz) - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 @@ -3036,6 +3036,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_d_base_sparse_mat = a%psb_d_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia, b%ia) @@ -3043,7 +3044,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) call move_alloc(a%val, b%val) call a%free() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -3077,13 +3078,14 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) call a%set_nzeros(b%get_nzeros()) call move_alloc(b%ia , a%ia ) call move_alloc(b%ja , a%ja ) call move_alloc(b%val, a%val ) call b%free() - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index c07b5b1b..84d5e705 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2139,8 +2139,7 @@ subroutine psb_d_cp_csc_from_coo(a,b,info) class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - + integer(psb_ipk_), intent(out) :: info type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) !locals diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index e1728baf..8775d142 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -2658,7 +2658,7 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) @@ -2667,13 +2667,13 @@ subroutine psb_d_cp_csr_from_coo(a,b,info) integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + character(len=20) :: name='d_cp_csr_from_coo' info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) 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 @@ -2869,15 +2869,15 @@ subroutine psb_d_mv_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_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) return 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. @@ -2887,6 +2887,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) call psb_realloc(max(nr+1,nc+1),a%irp,info) call b%free() + if (nza <= 0) then a%irp(:) = 1 else @@ -2936,7 +2937,6 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) endif - end subroutine psb_d_mv_csr_from_coo diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 238a2e65..288ae128 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -113,9 +113,13 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - + select type(b) + type is (psb_s_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + 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_ call psb_errpush(info,name, a_err='to/from coo') @@ -151,9 +155,14 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) ! info = psb_success_ call psb_erractionsave(err_act) - - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select if (info /= psb_success_) then info = psb_err_from_subroutine_ @@ -267,8 +276,13 @@ subroutine psb_s_base_mv_to_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) + select type(b) + type is (psb_s_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select return @@ -293,9 +307,13 @@ subroutine psb_s_base_mv_from_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - + select type(b) + type is (psb_s_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select return end subroutine psb_s_base_mv_from_fmt diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index f1436e0f..e06fc148 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -466,7 +466,7 @@ function psb_s_coo_get_nz_row(idx,a) result(res) res = 0 nza = a%get_nzeros() - if (a%is_sorted()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. ip = psb_ibsrch(idx,nza,a%ia) if (ip /= -1) return @@ -580,7 +580,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) end if if (beta == szero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -594,7 +594,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m @@ -933,7 +933,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) end if if (beta == szero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -951,7 +951,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -1650,7 +1650,7 @@ function psb_s_coo_csnmi(a) result(res) res = szero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_sorted()) then + if (a%is_by_rows()) then i = 1 j = i res = szero @@ -2067,7 +2067,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2344,7 +2344,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2884,7 +2884,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat - + call b%set_sort_status(a%get_sort_status()) nz = a%get_nzeros() call b%set_nzeros(nz) call b%reallocate(nz) @@ -2894,7 +2894,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) b%val(1:nz) = a%val(1:nz) - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -2912,7 +2912,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_coo implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - class(psb_s_coo_sparse_mat), intent(in) :: b + class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2925,7 +2925,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat - + call a%set_sort_status(b%get_sort_status()) nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -2934,7 +2934,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) a%ja(1:nz) = b%ja(1:nz) a%val(1:nz) = b%val(1:nz) - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 @@ -3036,6 +3036,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_s_base_sparse_mat = a%psb_s_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia, b%ia) @@ -3043,7 +3044,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) call move_alloc(a%val, b%val) call a%free() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -3077,13 +3078,14 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_s_base_sparse_mat = b%psb_s_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) call a%set_nzeros(b%get_nzeros()) call move_alloc(b%ia , a%ia ) call move_alloc(b%ja , a%ja ) call move_alloc(b%val, a%val ) call b%free() - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index d13020ed..ec4685fb 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -2139,8 +2139,7 @@ subroutine psb_s_cp_csc_from_coo(a,b,info) class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - + integer(psb_ipk_), intent(out) :: info type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) !locals diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index ed0a4982..fadbcf84 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -2658,7 +2658,7 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) @@ -2667,13 +2667,13 @@ subroutine psb_s_cp_csr_from_coo(a,b,info) integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + character(len=20) :: name='s_cp_csr_from_coo' info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) 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 @@ -2871,7 +2871,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) return nr = b%get_nrows() diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 27db9345..42e72e5d 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -113,9 +113,13 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) info = psb_success_ call psb_erractionsave(err_act) - call a%cp_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) - + select type(b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + 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_ call psb_errpush(info,name, a_err='to/from coo') @@ -151,9 +155,14 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) ! info = psb_success_ call psb_erractionsave(err_act) - - call b%cp_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select if (info /= psb_success_) then info = psb_err_from_subroutine_ @@ -267,8 +276,13 @@ subroutine psb_z_base_mv_to_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call a%mv_to_coo(tmp,info) - if (info == psb_success_) call b%mv_from_coo(tmp,info) + select type(b) + type is (psb_z_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select return @@ -293,9 +307,13 @@ subroutine psb_z_base_mv_from_fmt(a,b,info) ! Default implementation ! info = psb_success_ - call b%mv_to_coo(tmp,info) - if (info == psb_success_) call a%mv_from_coo(tmp,info) - + select type(b) + type is (psb_z_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select return end subroutine psb_z_base_mv_from_fmt diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index a894eb64..cd926959 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -466,7 +466,7 @@ function psb_z_coo_get_nz_row(idx,a) result(res) res = 0 nza = a%get_nzeros() - if (a%is_sorted()) then + if (a%is_by_rows()) then ! In this case we can do a binary search. ip = psb_ibsrch(idx,nza,a%ia) if (ip /= -1) return @@ -580,7 +580,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) end if if (beta == zzero) then - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -594,7 +594,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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_),tmp,size(tmp,1,kind=psb_ipk_),info) do i = 1, m @@ -933,7 +933,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) end if if (beta == zzero) then - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -951,7 +951,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) goto 9999 end if - call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),& + 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 @@ -1650,7 +1650,7 @@ function psb_z_coo_csnmi(a) result(res) res = dzero nnz = a%get_nzeros() is_unit = a%is_unit() - if (a%is_sorted()) then + if (a%is_by_rows()) then i = 1 j = i res = dzero @@ -2067,7 +2067,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2344,7 +2344,7 @@ contains nzin_ = 0 endif - if (a%is_sorted()) then + 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 ' @@ -2884,7 +2884,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat - + call b%set_sort_status(a%get_sort_status()) nz = a%get_nzeros() call b%set_nzeros(nz) call b%reallocate(nz) @@ -2894,7 +2894,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) b%val(1:nz) = a%val(1:nz) - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -2912,7 +2912,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_coo implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - class(psb_z_coo_sparse_mat), intent(in) :: b + class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act @@ -2925,7 +2925,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat - + call a%set_sort_status(b%get_sort_status()) nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -2934,7 +2934,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) a%ja(1:nz) = b%ja(1:nz) a%val(1:nz) = b%val(1:nz) - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 @@ -3036,6 +3036,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ b%psb_z_base_sparse_mat = a%psb_z_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia, b%ia) @@ -3043,7 +3044,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) call move_alloc(a%val, b%val) call a%free() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) goto 9999 @@ -3077,13 +3078,14 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ a%psb_z_base_sparse_mat = b%psb_z_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) call a%set_nzeros(b%get_nzeros()) call move_alloc(b%ia , a%ia ) call move_alloc(b%ja , a%ja ) call move_alloc(b%val, a%val ) call b%free() - if (.not.a%is_sorted()) call a%fix(info) + if (.not.a%is_by_rows()) call a%fix(info) if (info /= psb_success_) goto 9999 diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index 8dc1c8a2..c9acff5f 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2139,8 +2139,7 @@ subroutine psb_z_cp_csc_from_coo(a,b,info) class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info - + integer(psb_ipk_), intent(out) :: info type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) !locals diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index d9e9cb89..bd77634e 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -2658,7 +2658,7 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_), allocatable :: itemp(:) @@ -2667,13 +2667,13 @@ subroutine psb_z_cp_csr_from_coo(a,b,info) integer(psb_ipk_) :: nza, nr, i,j,irw, err_act, nc integer(psb_ipk_), Parameter :: maxtry=8 integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name + character(len=20) :: name='z_cp_csr_from_coo' info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) 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 @@ -2871,7 +2871,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) debug_level = psb_get_debug_level() - if (.not.b%is_sorted()) call b%fix(info) + if (.not.b%is_by_rows()) call b%fix(info) if (info /= psb_success_) return nr = b%get_nrows() diff --git a/config/pac.m4 b/config/pac.m4 index 27419db3..9cebf602 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -1860,8 +1860,8 @@ if test "x$pac_metis_header_ok" == "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $LIBS"; - AC_MSG_CHECKING([for METIS_PartGraphRecursive in $METIS_LIBS]) - AC_TRY_LINK_FUNC(METIS_PartGraphRecursive, + AC_MSG_CHECKING([for METIS_PartGraphKway in $METIS_LIBS]) + AC_TRY_LINK_FUNC(METIS_PartGraphKway, [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], [psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""]) AC_MSG_RESULT($pac_metis_lib_ok) @@ -1871,8 +1871,8 @@ if test "x$pac_metis_header_ok" == "xyes" ; then METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" - AC_MSG_CHECKING([for METIS_PartGraphRecursive in $METIS_LIBS]) - AC_TRY_LINK_FUNC(METIS_PartGraphRecursive, + AC_MSG_CHECKING([for METIS_PartGraphKway in $METIS_LIBS]) + AC_TRY_LINK_FUNC(METIS_PartGraphKway, [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], [psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""]) AC_MSG_RESULT($pac_metis_lib_ok) @@ -1882,8 +1882,8 @@ if test "x$pac_metis_header_ok" == "xyes" ; then METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" - AC_MSG_CHECKING([for METIS_PartGraphRecursive in $METIS_LIBS]) - AC_TRY_LINK_FUNC(METIS_PartGraphRecursive, + AC_MSG_CHECKING([for METIS_PartGraphKway in $METIS_LIBS]) + AC_TRY_LINK_FUNC(METIS_PartGraphKway, [psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; ], [psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS=""]) AC_MSG_RESULT($pac_metis_lib_ok) diff --git a/configure b/configure index f637c998..eebb497d 100755 --- a/configure +++ b/configure @@ -7385,7 +7385,37 @@ fi if test x"$pac_cv_serial_mpi" == x"yes" ; then FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; else - ac_exeext='' + ac_exeext='' +ac_ext='f90' +ac_link='${MPIFC-$FC} -o conftest${ac_exeext} $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +{ $as_echo "$as_me:$LINENO: checking MPI Fortran 2008 interface" >&5 +$as_echo_n "checking MPI Fortran 2008 interface... " >&6; } +cat > conftest.$ac_ext <&5 + (eval $ac_link) 2>&5 + ac_status=$? + $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && test -s conftest${ac_exeext}; then + pac_cv_mpi_f08="yes"; + { $as_echo "$as_me:$LINENO: result: use mpi_f08. " >&5 +$as_echo " use mpi_f08. " >&6; } + : +else + pac_cv_mpi_f08="no"; + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + { $as_echo "$as_me:$LINENO: result: no. " >&5 +$as_echo " no. " >&6; } +fi +rm -f conftest* + if test x"$pac_cv_mpi_f08" == x"yes" ; then + FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; + else + ac_exeext='' ac_ext='f90' ac_link='${MPIFC-$FC} -o conftest${ac_exeext} $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' { $as_echo "$as_me:$LINENO: checking MPI Fortran interface" >&5 @@ -7413,7 +7443,8 @@ $as_echo " include mpif.h " >&6; } FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES" fi rm -f conftest* - fi + fi +fi { $as_echo "$as_me:$LINENO: checking whether we want long (8 bytes) integers" >&5 @@ -9943,8 +9974,8 @@ if test "x$pac_metis_header_ok" == "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $LIBS"; - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in $METIS_LIBS" >&5 -$as_echo_n "checking for METIS_PartGraphRecursive in $METIS_LIBS... " >&6; } + { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 +$as_echo_n "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF @@ -9958,11 +9989,11 @@ cat >>conftest.$ac_ext <<_ACEOF #ifdef __cplusplus extern "C" #endif -char METIS_PartGraphRecursive (); +char METIS_PartGraphKway (); int main () { -return METIS_PartGraphRecursive (); +return METIS_PartGraphKway (); ; return 0; } @@ -10006,8 +10037,8 @@ $as_echo "$pac_metis_lib_ok" >&6; } METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in $METIS_LIBS" >&5 -$as_echo_n "checking for METIS_PartGraphRecursive in $METIS_LIBS... " >&6; } + { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 +$as_echo_n "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF @@ -10021,11 +10052,11 @@ cat >>conftest.$ac_ext <<_ACEOF #ifdef __cplusplus extern "C" #endif -char METIS_PartGraphRecursive (); +char METIS_PartGraphKway (); int main () { -return METIS_PartGraphRecursive (); +return METIS_PartGraphKway (); ; return 0; } @@ -10069,8 +10100,8 @@ $as_echo "$pac_metis_lib_ok" >&6; } METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphRecursive in $METIS_LIBS" >&5 -$as_echo_n "checking for METIS_PartGraphRecursive in $METIS_LIBS... " >&6; } + { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 +$as_echo_n "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF @@ -10084,11 +10115,11 @@ cat >>conftest.$ac_ext <<_ACEOF #ifdef __cplusplus extern "C" #endif -char METIS_PartGraphRecursive (); +char METIS_PartGraphKway (); int main () { -return METIS_PartGraphRecursive (); +return METIS_PartGraphKway (); ; return 0; } diff --git a/configure.ac b/configure.ac index d609dafe..946933d4 100755 --- a/configure.ac +++ b/configure.ac @@ -515,15 +515,16 @@ fi if test x"$pac_cv_serial_mpi" == x"yes" ; then FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; else -dnl PAC_FORTRAN_CHECK_HAVE_MPI_MOD_F08() -dnl if test x"$pac_cv_mpi_f08" == x"yes" ; then + PAC_FORTRAN_CHECK_HAVE_MPI_MOD_F08() + if test x"$pac_cv_mpi_f08" == x"yes" ; then dnl FDEFINES="$psblas_cv_define_prepend-DMPI_MOD_F08 $FDEFINES"; -dnl else - PAC_FORTRAN_CHECK_HAVE_MPI_MOD( - [FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"], - [FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES"]) - fi -dnl fi + FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; + else + PAC_FORTRAN_CHECK_HAVE_MPI_MOD( + [FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"], + [FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES"]) + fi +fi PAC_ARG_LONG_INTEGERS if test x"$pac_cv_long_integers" == x"yes" ; then diff --git a/util/metis_int.c b/util/metis_int.c index 645f06fe..b9d258b4 100644 --- a/util/metis_int.c +++ b/util/metis_int.c @@ -2,10 +2,10 @@ #if defined(HAVE_METIS_) #include "metis.h" -/* extern int METIS_PartGraphRecursive(int *, int *, int *, int *, int *, int *, int *, int *, float *, float, int *, int *, int *); */ +/* extern int METIS_PartGraphKway(int *, int *, int *, int *, int *, int *, int *, int *, float *, float, int *, int *, int *); */ -int metis_PartGraphRecursive_C(int *n, int *ixadj, int *iadj, int *ivwg, +int metis_PartGraphKway_C(int *n, int *ixadj, int *iadj, int *ivwg, int *iajw, int *nparts, float *weights, int *graphpart) { @@ -19,14 +19,14 @@ int metis_PartGraphRecursive_C(int *n, int *ixadj, int *iadj, int *ivwg, //printf("n:%p ncon:%p ixadj:%p iadj:%p npart:%p weights:%p options:%p objval:%p graphpart: %p\n",n,&ncon,ixadj,iadj,nparts,NULL,options,&objval,graphpart); /* fprintf(stderr,"From metis_int: %f\n",weights[0]); */ if (weights[0] == -1.0) { - res = METIS_PartGraphRecursive((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, + res = METIS_PartGraphKway((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, NULL,NULL,NULL,(idx_t *)nparts,NULL,NULL,options, &objval,(idx_t *)graphpart); } else { - /* res = METIS_PartGraphRecursive((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, */ + /* res = METIS_PartGraphKway((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, */ /* NULL,NULL,NULL,(idx_t *)nparts,NULL,NULL,NULL, */ /* &objval,(idx_t *)graphpart); */ - res = METIS_PartGraphRecursive((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, + res = METIS_PartGraphKway((idx_t*)n,(idx_t *)&ncon,(idx_t *)ixadj,(idx_t *)iadj, NULL,NULL,NULL,(idx_t *)nparts,weights,NULL,options, &objval,(idx_t *)graphpart); } @@ -40,7 +40,7 @@ int metis_PartGraphRecursive_C(int *n, int *ixadj, int *iadj, int *ivwg, #else -int metis_PartGraphRecursive_C(int *n, int *ixadj, int *iadj, int *ivwg, +int metis_PartGraphKway_C(int *n, int *ixadj, int *iadj, int *ivwg, int *iajw, int *nparts, float *weights, int *graphpart) { diff --git a/util/psb_d_mmio_impl.f90 b/util/psb_d_mmio_impl.f90 index 43903031..dfc0dc42 100644 --- a/util/psb_d_mmio_impl.f90 +++ b/util/psb_d_mmio_impl.f90 @@ -335,10 +335,14 @@ subroutine dmm_mat_read(a, info, iunit, filename) read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),acoo%val(i) end do call acoo%set_nzeros(nnzero) - call acoo%fix(info) - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') + else if ((psb_tolower(type) == 'pattern').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i) + end do + acoo%val(:) = done + call acoo%set_nzeros(nnzero) else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then ! we are generally working with non-symmetric matrices, so @@ -357,15 +361,34 @@ subroutine dmm_mat_read(a, info, iunit, filename) end if end do call acoo%set_nzeros(nzr) - call acoo%fix(info) - call a%mv_from(acoo) - call a%cscnv(ircode,type='csr') + else if ((psb_tolower(type) == 'pattern').and.(psb_tolower(sym) == 'symmetric')) then + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i) + end do + acoo%val(:) = done + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) else write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' info=904 end if + + if (info == 0) then + call acoo%fix(info) + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + end if + if (infile /= 5) close(infile) return diff --git a/util/psb_metispart_mod.F90 b/util/psb_metispart_mod.F90 index b4c2fd0f..b11d4f55 100644 --- a/util/psb_metispart_mod.F90 +++ b/util/psb_metispart_mod.F90 @@ -45,7 +45,7 @@ ! integer(psb_ipk_) :: NPARTS How many parts we are requiring to the ! partition utility ! -! DISTR_MTPART(RROOT,CROOT,ICTXT): This subroutine will be called by +! DISTR_MTPART(ROOT,ICTXT): This subroutine will be called by ! all processes to distribute the information computed by the root ! process, to be used subsequently. ! @@ -55,14 +55,21 @@ ! module psb_metispart_mod use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_cspmat_type,& - & psb_dspmat_type, psb_zspmat_type, psb_err_unit, psb_mpik_ + & psb_dspmat_type, psb_zspmat_type, psb_err_unit, psb_mpik_,& + & psb_s_csr_sparse_mat, psb_d_csr_sparse_mat, & + & psb_c_csr_sparse_mat, psb_z_csr_sparse_mat public part_graph, build_mtpart, distr_mtpart,& & getv_mtpart, free_part private integer(psb_ipk_), allocatable, save :: graph_vect(:) interface build_mtpart - module procedure build_mtpart, d_mat_build_mtpart, s_mat_build_mtpart, z_mat_build_mtpart, c_mat_build_mtpart + module procedure build_mtpart,& + & d_mat_build_mtpart, s_mat_build_mtpart,& + & z_mat_build_mtpart, c_mat_build_mtpart, & + & d_csr_build_mtpart, s_csr_build_mtpart,& + & z_csr_build_mtpart, c_csr_build_mtpart + end interface contains @@ -154,11 +161,10 @@ contains if (allocated(wgh_)) then call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_) else - call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_) + call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts) end if class default write(psb_err_unit,*) 'Sorry, right now we only take CSR input!' - call psb_abort(ictxt) end select end subroutine d_mat_build_mtpart @@ -173,7 +179,7 @@ contains select type (aa=>a%a) - type is (psb_z_csr_sparse_mat) + type is (psb_z_csr_sparse_mat) if (present(weights)) then if (size(weights)==nparts) then wgh_ = weights @@ -182,11 +188,10 @@ contains if (allocated(wgh_)) then call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_) else - call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,wgh_) + call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts) end if class default write(psb_err_unit,*) 'Sorry, right now we only take CSR input!' - call psb_abort(ictxt) end select end subroutine z_mat_build_mtpart @@ -204,7 +209,6 @@ contains call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,weights) class default write(psb_err_unit,*) 'Sorry, right now we only take CSR input!' - call psb_abort(ictxt) end select end subroutine s_mat_build_mtpart @@ -222,11 +226,79 @@ contains call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts,weights) class default write(psb_err_unit,*) 'Sorry, right now we only take CSR input!' - call psb_abort(ictxt) end select end subroutine c_mat_build_mtpart + + subroutine d_csr_build_mtpart(a,nparts,weights) + use psb_base_mod + type(psb_d_csr_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: nparts + real(psb_dpk_), optional :: weights(:) + real(psb_spk_), allocatable :: wgh_(:) + + + if (present(weights)) then + if (size(weights)==nparts) then + wgh_ = weights + end if + end if + if (allocated(wgh_)) then + call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_) + else + call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts) + end if + + end subroutine d_csr_build_mtpart + + subroutine z_csr_build_mtpart(a,nparts,weights) + use psb_base_mod + type(psb_z_csr_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: nparts + real(psb_dpk_), optional :: weights(:) + real(psb_spk_), allocatable :: wgh_(:) + + + if (present(weights)) then + if (size(weights)==nparts) then + wgh_ = weights + end if + end if + if (allocated(wgh_)) then + call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_) + else + call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts) + end if + + end subroutine z_csr_build_mtpart + + + subroutine s_csr_build_mtpart(a,nparts,weights) + use psb_base_mod + type(psb_s_csr_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: nparts + real(psb_spk_), optional :: weights(:) + + + call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights) + + end subroutine s_csr_build_mtpart + + + subroutine c_csr_build_mtpart(a,nparts,weights) + use psb_base_mod + type(psb_c_csr_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: nparts + real(psb_spk_), optional :: weights(:) + + + call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights) + + end subroutine c_csr_build_mtpart + + + subroutine build_mtpart(n,fida,ja,irp,nparts,weights) use psb_base_mod implicit none @@ -244,7 +316,7 @@ contains #if defined(HAVE_METIS) interface - ! subroutine METIS_PartGraphRecursive(n,ixadj,iadj,ivwg,iajw,& + ! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,& ! & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c) ! use iso_c_binding ! integer(c_int) :: n,wgflag,numflag,nparts,nedc @@ -252,10 +324,10 @@ contains ! real(c_float) :: weights(*) ! !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc ! !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) - ! end subroutine METIS_PartGraphRecursive + ! end subroutine METIS_PartGraphKway - function METIS_PartGraphRecursive(n,ixadj,iadj,ivwg,iajw,& - & nparts,weights,part) bind(c,name="metis_PartGraphRecursive_C") result(res) + function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,& + & nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res) use iso_c_binding integer(c_int) :: res integer(c_int) :: n,nparts @@ -263,7 +335,7 @@ contains real(c_float) :: weights(*) !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) - end function METIS_PartGraphRecursive + end function METIS_PartGraphKway end interface call psb_realloc(n,graph_vect,info) @@ -280,7 +352,7 @@ contains numflag = 1 wgflag = 0 - write(*,*) 'Before allocation',nparts +!!$ write(*,*) 'Before allocation',nparts irpl=irp jal = ja @@ -289,23 +361,23 @@ contains wgh_ = -1.0 if(present(weights)) then if (size(weights) == nptl) then - write(*,*) 'weights present',weights - ! call METIS_PartGraphRecursive(n,irp,ja,idummy,jdummy,& +!!$ write(*,*) 'weights present',weights + ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,& ! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect) - info = METIS_PartGraphRecursive(nl,irpl,jal,idummy,jdummy,& + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& & nptl,weights,gvl) else - write(*,*) 'weights absent',wgh_ - info = METIS_PartGraphRecursive(nl,irpl,jal,idummy,jdummy,& +!!$ write(*,*) 'weights absent',wgh_ + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& & nptl,wgh_,gvl) end if else - write(*,*) 'weights absent',wgh_ - info = METIS_PartGraphRecursive(nl,irpl,jal,idummy,jdummy,& +!!$ write(*,*) 'weights absent',wgh_ + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& & nptl,wgh_,gvl) endif - write(*,*) 'after allocation',info +!!$ write(*,*) 'after allocation',info do i=1, n graph_vect(i) = gvl(i) - 1