From 9ef5179ecc5173f349f0a9b5d321c588c6c58ad6 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 5 May 2026 12:35:03 +0200 Subject: [PATCH 1/4] Test --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index d3c36e25..01d79f13 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ include Make.inc - + all: dirs mods objs libd @echo "=====================================" @echo "PSBLAS libraries Compilation Successful." From 914dd33e4a3c108781e00f38695ce1f9c73eab90 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 5 May 2026 15:42:29 +0200 Subject: [PATCH 2/4] Maintenance fixes --- base/modules/serial/psb_c_base_vect_mod.F90 | 23 ++++++- base/modules/serial/psb_c_vect_mod.F90 | 14 ++++- base/modules/serial/psb_d_base_vect_mod.F90 | 25 ++++++-- base/modules/serial/psb_d_vect_mod.F90 | 16 ++++- base/modules/serial/psb_s_base_vect_mod.F90 | 25 ++++++-- base/modules/serial/psb_s_vect_mod.F90 | 16 ++++- base/modules/serial/psb_z_base_vect_mod.F90 | 23 ++++++- base/modules/serial/psb_z_vect_mod.F90 | 14 ++++- base/modules/tools/psb_c_tools_mod.F90 | 11 ++++ base/modules/tools/psb_d_tools_mod.F90 | 11 ++++ base/modules/tools/psb_s_tools_mod.F90 | 11 ++++ base/modules/tools/psb_z_tools_mod.F90 | 11 ++++ cbind/base/psb_c_serial_cbind_mod.F90 | 68 +++++++++++++++++++++ cbind/base/psb_c_tools_cbind_mod.F90 | 36 +++++++++++ cbind/base/psb_d_serial_cbind_mod.F90 | 68 +++++++++++++++++++++ cbind/base/psb_d_tools_cbind_mod.F90 | 36 +++++++++++ cbind/base/psb_s_serial_cbind_mod.F90 | 68 +++++++++++++++++++++ cbind/base/psb_s_tools_cbind_mod.F90 | 36 +++++++++++ cbind/base/psb_z_serial_cbind_mod.F90 | 68 +++++++++++++++++++++ cbind/base/psb_z_tools_cbind_mod.F90 | 36 +++++++++++ test/pdegen/psb_d_pde2d.F90 | 6 +- test/pdegen/psb_d_pde3d.F90 | 8 +-- test/pdegen/psb_s_pde2d.F90 | 6 +- test/pdegen/psb_s_pde3d.F90 | 8 +-- 24 files changed, 606 insertions(+), 38 deletions(-) diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index 2f4db972..be652207 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -129,6 +129,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: set_vect => c_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> c_base_get_entry + procedure, pass(x) :: set_entry=> c_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -903,14 +904,30 @@ contains ! function c_base_get_entry(x, index) result(res) implicit none - class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res - res = 0 - if (allocated(x%v)) res = x%v(index) + res = czero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function c_base_get_entry + + subroutine c_base_set_entry(x, index, val) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) = val + call x%set_host() + end if + end subroutine c_base_set_entry ! ! Overwrite with absolute value diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index da5f1606..cdc260b5 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -93,6 +93,7 @@ module psb_c_vect_mod procedure, pass(x) :: set_sync => c_vect_set_sync procedure, pass(x) :: get_entry => c_vect_get_entry + procedure, pass(x) :: set_entry => c_vect_set_entry procedure, pass(x) :: dot_v => c_vect_dot_v procedure, pass(x) :: dot_a => c_vect_dot_a @@ -680,13 +681,22 @@ contains function c_vect_get_entry(x,index) result(res) implicit none - class(psb_c_vect_type), intent(in) :: x + class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res - res = 0 + res = czero if (allocated(x%v)) res = x%v%get_entry(index) end function c_vect_get_entry + subroutine c_vect_set_entry(x,index,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine c_vect_set_entry + function c_vect_dot_v(n,x,y) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x, y diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index 36ef9d8b..e9841652 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -129,6 +129,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: set_vect => d_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> d_base_get_entry + procedure, pass(x) :: set_entry=> d_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -910,14 +911,30 @@ contains ! function d_base_get_entry(x, index) result(res) implicit none - class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res - res = 0 - if (allocated(x%v)) res = x%v(index) + res = dzero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function d_base_get_entry + + subroutine d_base_set_entry(x, index, val) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) = val + call x%set_host() + end if + end subroutine d_base_set_entry ! ! Overwrite with absolute value @@ -1810,8 +1827,8 @@ contains integer(psb_ipk_) :: i if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) res = HUGE(done) +#if defined(PSB_OPENMP) !$omp parallel do private(i) reduction(min: res) do i=1, n res = min(res,abs(x%v(i))) diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index ae241c24..a192c161 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -93,6 +93,7 @@ module psb_d_vect_mod procedure, pass(x) :: set_sync => d_vect_set_sync procedure, pass(x) :: get_entry => d_vect_get_entry + procedure, pass(x) :: set_entry => d_vect_set_entry procedure, pass(x) :: dot_v => d_vect_dot_v procedure, pass(x) :: dot_a => d_vect_dot_a @@ -687,13 +688,22 @@ contains function d_vect_get_entry(x,index) result(res) implicit none - class(psb_d_vect_type), intent(in) :: x + class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res - res = 0 + res = dzero if (allocated(x%v)) res = x%v%get_entry(index) end function d_vect_get_entry + subroutine d_vect_set_entry(x,index,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine d_vect_set_entry + function d_vect_dot_v(n,x,y) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x, y @@ -1255,7 +1265,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = dzero + res = HUGE(dzero) end if end function d_vect_min diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index 6c2a9597..57125704 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -129,6 +129,7 @@ module psb_s_base_vect_mod procedure, pass(x) :: set_vect => s_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> s_base_get_entry + procedure, pass(x) :: set_entry=> s_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -910,14 +911,30 @@ contains ! function s_base_get_entry(x, index) result(res) implicit none - class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res - res = 0 - if (allocated(x%v)) res = x%v(index) + res = szero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function s_base_get_entry + + subroutine s_base_set_entry(x, index, val) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) = val + call x%set_host() + end if + end subroutine s_base_set_entry ! ! Overwrite with absolute value @@ -1810,8 +1827,8 @@ contains integer(psb_ipk_) :: i if (x%is_dev()) call x%sync() -#if defined(PSB_OPENMP) res = HUGE(sone) +#if defined(PSB_OPENMP) !$omp parallel do private(i) reduction(min: res) do i=1, n res = min(res,abs(x%v(i))) diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 95b529ec..ef2c36e3 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -93,6 +93,7 @@ module psb_s_vect_mod procedure, pass(x) :: set_sync => s_vect_set_sync procedure, pass(x) :: get_entry => s_vect_get_entry + procedure, pass(x) :: set_entry => s_vect_set_entry procedure, pass(x) :: dot_v => s_vect_dot_v procedure, pass(x) :: dot_a => s_vect_dot_a @@ -687,13 +688,22 @@ contains function s_vect_get_entry(x,index) result(res) implicit none - class(psb_s_vect_type), intent(in) :: x + class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res - res = 0 + res = szero if (allocated(x%v)) res = x%v%get_entry(index) end function s_vect_get_entry + subroutine s_vect_set_entry(x,index,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine s_vect_set_entry + function s_vect_dot_v(n,x,y) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x, y @@ -1255,7 +1265,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = szero + res = HUGE(szero) end if end function s_vect_min diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index 0ace4a90..583b9b4f 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -129,6 +129,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: set_vect => z_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> z_base_get_entry + procedure, pass(x) :: set_entry=> z_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -903,14 +904,30 @@ contains ! function z_base_get_entry(x, index) result(res) implicit none - class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res - res = 0 - if (allocated(x%v)) res = x%v(index) + res = zzero + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function z_base_get_entry + + subroutine z_base_set_entry(x, index, val) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) = val + call x%set_host() + end if + end subroutine z_base_set_entry ! ! Overwrite with absolute value diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 650102e0..5986873d 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -93,6 +93,7 @@ module psb_z_vect_mod procedure, pass(x) :: set_sync => z_vect_set_sync procedure, pass(x) :: get_entry => z_vect_get_entry + procedure, pass(x) :: set_entry => z_vect_set_entry procedure, pass(x) :: dot_v => z_vect_dot_v procedure, pass(x) :: dot_a => z_vect_dot_a @@ -680,13 +681,22 @@ contains function z_vect_get_entry(x,index) result(res) implicit none - class(psb_z_vect_type), intent(in) :: x + class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res - res = 0 + res = zzero if (allocated(x%v)) res = x%v%get_entry(index) end function z_vect_get_entry + subroutine z_vect_set_entry(x,index,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine z_vect_set_entry + function z_vect_dot_v(n,x,y) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x, y diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 82ac7dbb..268889e1 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -443,6 +443,17 @@ Module psb_c_tools_mod end function end interface + interface psb_setelem + subroutine psb_c_setelem(index,val,x,desc_a,info) + import + type(psb_c_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) ::val + end subroutine psb_c_setelem + end interface + interface psb_remap subroutine psb_c_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 7a1f7923..2866aac1 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -443,6 +443,17 @@ Module psb_d_tools_mod end function end interface + interface psb_setelem + subroutine psb_d_setelem(index,val,x,desc_a,info) + import + type(psb_d_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) ::val + end subroutine psb_d_setelem + end interface + interface psb_remap subroutine psb_d_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index abcff985..b48d6167 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -443,6 +443,17 @@ Module psb_s_tools_mod end function end interface + interface psb_setelem + subroutine psb_s_setelem(index,val,x,desc_a,info) + import + type(psb_s_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) ::val + end subroutine psb_s_setelem + end interface + interface psb_remap subroutine psb_s_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index f58b12db..611ab408 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -443,6 +443,17 @@ Module psb_z_tools_mod end function end interface + interface psb_setelem + subroutine psb_z_setelem(index,val,x,desc_a,info) + import + type(psb_z_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) ::val + end subroutine psb_z_setelem + end interface + interface psb_remap subroutine psb_z_remap(np_remap, desc_in, a_in, & & ipd, isrc, nrsrc, naggr, desc_out, a_out, info) diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index b298d84a..ab8ad7e1 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -180,6 +180,30 @@ contains end function psb_c_cvect_set_scal + function psb_c_cvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + complex(c_float_complex) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_cvect_set_scal_bound + function psb_c_cvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -204,5 +228,49 @@ contains end function psb_c_cvect_set_vect + function psb_c_cvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_float_complex), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_cvect_set_entry + + function psb_c_cvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + complex(c_float_complex) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_cvect_get_entry end module psb_c_serial_cbind_mod diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index b7895de2..90a44b5a 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -452,4 +452,40 @@ contains end function psb_c_cgetelem + function psb_c_csetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_cvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: val + integer(psb_c_ipk_) :: res + + type(psb_c_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_csetelem + end module psb_c_tools_cbind_mod diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 984f826f..dc559c64 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -180,6 +180,30 @@ contains end function psb_c_dvect_set_scal + function psb_c_dvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + real(c_double) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_dvect_set_scal_bound + function psb_c_dvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -204,5 +228,49 @@ contains end function psb_c_dvect_set_vect + function psb_c_dvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_double), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_dvect_set_entry + + function psb_c_dvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + real(c_double) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_dvect_get_entry end module psb_d_serial_cbind_mod diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index 2de6990c..46a1656d 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -452,4 +452,40 @@ contains end function psb_c_dgetelem + function psb_c_dsetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_dvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_double), value :: val + integer(psb_c_ipk_) :: res + + type(psb_d_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_dsetelem + end module psb_d_tools_cbind_mod diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index 83dac1a5..93fc7f8d 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -180,6 +180,30 @@ contains end function psb_c_svect_set_scal + function psb_c_svect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + real(c_float) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_svect_set_scal_bound + function psb_c_svect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -204,5 +228,49 @@ contains end function psb_c_svect_set_vect + function psb_c_svect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_float), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_svect_set_entry + + function psb_c_svect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + real(c_float) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_svect_get_entry end module psb_s_serial_cbind_mod diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index 517ad361..1bc8b7f4 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -452,4 +452,40 @@ contains end function psb_c_sgetelem + function psb_c_ssetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_svector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_float), value :: val + integer(psb_c_ipk_) :: res + + type(psb_s_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_ssetelem + end module psb_s_tools_cbind_mod diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index b61060b9..15a46bb5 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -180,6 +180,30 @@ contains end function psb_c_zvect_set_scal + function psb_c_zvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + complex(c_double_complex) :: val + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + call xp%set(val,first=ifirst,last=ilast) + + info = 0 + + end function psb_c_zvect_set_scal_bound + function psb_c_zvect_set_vect(x,val,n) bind(c) result(info) use psb_base_mod implicit none @@ -204,5 +228,49 @@ contains end function psb_c_zvect_set_vect + function psb_c_zvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_double_complex), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_zvect_set_entry + + function psb_c_zvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + complex(c_double_complex) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_zvect_get_entry end module psb_z_serial_cbind_mod diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index 3e94b715..61e0454e 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -452,4 +452,40 @@ contains end function psb_c_zgetelem + function psb_c_zsetelem(index,val,xh,cdh) bind(c) result(res) + implicit none + + type(psb_c_zvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: val + integer(psb_c_ipk_) :: res + + type(psb_z_vect_type), pointer :: xp + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + call psb_setelem(index,val,xp,descp,info) + else + call psb_setelem(index+(1-ixb),val,xp,descp,info) + end if + res=info + return + + end function psb_c_zsetelem + end module psb_z_tools_cbind_mod diff --git a/test/pdegen/psb_d_pde2d.F90 b/test/pdegen/psb_d_pde2d.F90 index abb70826..4e65ad56 100644 --- a/test/pdegen/psb_d_pde2d.F90 +++ b/test/pdegen/psb_d_pde2d.F90 @@ -230,7 +230,7 @@ contains f_ => d_null_func_2d end if - deltah = done/(idim+1) + deltah = done/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*done)* deltah @@ -467,8 +467,8 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,glob_row,idim,idim) ! x, y coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah + x = (ix)*deltah + y = (iy)*deltah zt(k) = f_(x,y) ! internal point: build discretization diff --git a/test/pdegen/psb_d_pde3d.F90 b/test/pdegen/psb_d_pde3d.F90 index ab268e7d..977ab77d 100644 --- a/test/pdegen/psb_d_pde3d.F90 +++ b/test/pdegen/psb_d_pde3d.F90 @@ -246,7 +246,7 @@ contains f_ => d_null_func_3d end if - deltah = done/(idim+1) + deltah = done/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*done)* deltah @@ -496,9 +496,9 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah + x = (ix)*deltah + y = (iy)*deltah + z = (iz)*deltah zt(k) = f_(x,y,z) ! internal point: build discretization ! diff --git a/test/pdegen/psb_s_pde2d.F90 b/test/pdegen/psb_s_pde2d.F90 index de85a80c..54461e86 100644 --- a/test/pdegen/psb_s_pde2d.F90 +++ b/test/pdegen/psb_s_pde2d.F90 @@ -230,7 +230,7 @@ contains f_ => s_null_func_2d end if - deltah = sone/(idim+1) + deltah = sone/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*sone)* deltah @@ -467,8 +467,8 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,glob_row,idim,idim) ! x, y coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah + x = (ix)*deltah + y = (iy)*deltah zt(k) = f_(x,y) ! internal point: build discretization diff --git a/test/pdegen/psb_s_pde3d.F90 b/test/pdegen/psb_s_pde3d.F90 index 5b2be8ee..5b3d76da 100644 --- a/test/pdegen/psb_s_pde3d.F90 +++ b/test/pdegen/psb_s_pde3d.F90 @@ -246,7 +246,7 @@ contains f_ => s_null_func_3d end if - deltah = sone/(idim+1) + deltah = sone/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*sone)* deltah @@ -496,9 +496,9 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah + x = (ix)*deltah + y = (iy)*deltah + z = (iz)*deltah zt(k) = f_(x,y,z) ! internal point: build discretization ! From ed138c8afd74bc5587779d59206d43bed1dbbce7 Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 5 May 2026 16:58:17 +0200 Subject: [PATCH 3/4] Fix matrix generation --- test/pdegen/psb_d_pde2d.F90 | 2 +- test/pdegen/psb_d_pde3d.F90 | 2 +- test/pdegen/psb_s_pde2d.F90 | 2 +- test/pdegen/psb_s_pde3d.F90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/test/pdegen/psb_d_pde2d.F90 b/test/pdegen/psb_d_pde2d.F90 index 4e65ad56..6f472b69 100644 --- a/test/pdegen/psb_d_pde2d.F90 +++ b/test/pdegen/psb_d_pde2d.F90 @@ -230,7 +230,7 @@ contains f_ => d_null_func_2d end if - deltah = done/(idim+2) + deltah = done/(idim+1) sqdeltah = deltah*deltah deltah2 = (2*done)* deltah diff --git a/test/pdegen/psb_d_pde3d.F90 b/test/pdegen/psb_d_pde3d.F90 index 977ab77d..c9c1634b 100644 --- a/test/pdegen/psb_d_pde3d.F90 +++ b/test/pdegen/psb_d_pde3d.F90 @@ -246,7 +246,7 @@ contains f_ => d_null_func_3d end if - deltah = done/(idim+2) + deltah = done/(idim+1) sqdeltah = deltah*deltah deltah2 = (2*done)* deltah diff --git a/test/pdegen/psb_s_pde2d.F90 b/test/pdegen/psb_s_pde2d.F90 index 54461e86..55902bdb 100644 --- a/test/pdegen/psb_s_pde2d.F90 +++ b/test/pdegen/psb_s_pde2d.F90 @@ -230,7 +230,7 @@ contains f_ => s_null_func_2d end if - deltah = sone/(idim+2) + deltah = sone/(idim+1) sqdeltah = deltah*deltah deltah2 = (2*sone)* deltah diff --git a/test/pdegen/psb_s_pde3d.F90 b/test/pdegen/psb_s_pde3d.F90 index 5b3d76da..9b818dc7 100644 --- a/test/pdegen/psb_s_pde3d.F90 +++ b/test/pdegen/psb_s_pde3d.F90 @@ -246,7 +246,7 @@ contains f_ => s_null_func_3d end if - deltah = sone/(idim+2) + deltah = sone/(idim+1) sqdeltah = deltah*deltah deltah2 = (2*sone)* deltah From 9e1c7b775e7ce028aa23be1938a8c0331bd2ff1f Mon Sep 17 00:00:00 2001 From: sfilippone Date: Tue, 12 May 2026 13:27:24 +0200 Subject: [PATCH 4/4] Fix (de)allocate prec and SolverOptions --- cbind/linsolve/psb_base_linsolve_cbind_mod.f90 | 2 +- cbind/linsolve/psb_clinsolve_cbind_mod.f90 | 7 +++++-- cbind/linsolve/psb_dlinsolve_cbind_mod.f90 | 7 +++++-- cbind/linsolve/psb_linsolve_cbind.h | 2 +- cbind/linsolve/psb_slinsolve_cbind_mod.f90 | 7 +++++-- cbind/linsolve/psb_zlinsolve_cbind_mod.f90 | 7 +++++-- prec/impl/psb_c_bjacprec_impl.f90 | 4 ++++ prec/impl/psb_c_diagprec_impl.f90 | 2 +- prec/impl/psb_d_bjacprec_impl.f90 | 4 ++++ prec/impl/psb_d_diagprec_impl.f90 | 2 +- prec/impl/psb_s_bjacprec_impl.f90 | 4 ++++ prec/impl/psb_s_diagprec_impl.f90 | 2 +- prec/impl/psb_z_bjacprec_impl.f90 | 4 ++++ prec/impl/psb_z_diagprec_impl.f90 | 2 +- 14 files changed, 42 insertions(+), 14 deletions(-) diff --git a/cbind/linsolve/psb_base_linsolve_cbind_mod.f90 b/cbind/linsolve/psb_base_linsolve_cbind_mod.f90 index db9f9d35..316e5cc4 100644 --- a/cbind/linsolve/psb_base_linsolve_cbind_mod.f90 +++ b/cbind/linsolve/psb_base_linsolve_cbind_mod.f90 @@ -27,7 +27,7 @@ contains function psb_c_PrintSolverOptions(options)& & bind(c,name='psb_c_PrintSolverOptions') result(res) implicit none - type(solveroptions) :: options + type(solveroptions), value :: options integer(psb_c_ipk_) :: res write(*,*) 'PSBLAS C Interface Solver Options ' diff --git a/cbind/linsolve/psb_clinsolve_cbind_mod.f90 b/cbind/linsolve/psb_clinsolve_cbind_mod.f90 index 29a0b2fc..b4d9b48c 100644 --- a/cbind/linsolve/psb_clinsolve_cbind_mod.f90 +++ b/cbind/linsolve/psb_clinsolve_cbind_mod.f90 @@ -32,6 +32,7 @@ contains function psb_c_ckrylov_opt(methd,& & ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res) use psb_base_mod + use psb_error_mod use psb_prec_mod use psb_linsolve_mod use psb_objhandle_mod @@ -53,7 +54,7 @@ contains type(psb_cprec_type), pointer :: precp type(psb_c_vect_type), pointer :: xp, bp - integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter + integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act character(len=20) :: fmethd real(psb_spk_) :: feps,ferr @@ -91,7 +92,8 @@ contains fitrace = itrace first = irst fistop = istop - + err_act = psb_act_abort_ + if (psb_errstatus_fatal()) call psb_error_handler(err_act) call psb_krylov(fmethd, ap, precp, bp, xp, feps, & & descp, info,& & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,& @@ -99,6 +101,7 @@ contains iter = fiter err = ferr res = info + if (psb_errstatus_fatal()) call psb_error_handler(err_act) end function psb_c_ckrylov_opt diff --git a/cbind/linsolve/psb_dlinsolve_cbind_mod.f90 b/cbind/linsolve/psb_dlinsolve_cbind_mod.f90 index 35612ec3..5feac2cb 100644 --- a/cbind/linsolve/psb_dlinsolve_cbind_mod.f90 +++ b/cbind/linsolve/psb_dlinsolve_cbind_mod.f90 @@ -32,6 +32,7 @@ contains function psb_c_dkrylov_opt(methd,& & ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res) use psb_base_mod + use psb_error_mod use psb_prec_mod use psb_linsolve_mod use psb_objhandle_mod @@ -53,7 +54,7 @@ contains type(psb_dprec_type), pointer :: precp type(psb_d_vect_type), pointer :: xp, bp - integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter + integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act character(len=20) :: fmethd real(psb_dpk_) :: feps,ferr @@ -91,7 +92,8 @@ contains fitrace = itrace first = irst fistop = istop - + err_act = psb_act_abort_ + if (psb_errstatus_fatal()) call psb_error_handler(err_act) call psb_krylov(fmethd, ap, precp, bp, xp, feps, & & descp, info,& & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,& @@ -99,6 +101,7 @@ contains iter = fiter err = ferr res = info + if (psb_errstatus_fatal()) call psb_error_handler(err_act) end function psb_c_dkrylov_opt diff --git a/cbind/linsolve/psb_linsolve_cbind.h b/cbind/linsolve/psb_linsolve_cbind.h index d86bf216..41bb7ed1 100644 --- a/cbind/linsolve/psb_linsolve_cbind.h +++ b/cbind/linsolve/psb_linsolve_cbind.h @@ -25,7 +25,7 @@ typedef struct psb_c_solveroptions { } psb_c_SolverOptions; int psb_c_DefaultSolverOptions(psb_c_SolverOptions *opt); -int psb_c_PrintSolverOptions(psb_c_SolverOptions *opt); +int psb_c_PrintSolverOptions(psb_c_SolverOptions opt); int psb_c_skrylov(const char *method, psb_c_sspmat *ah, psb_c_sprec *ph, psb_c_svector *bh, psb_c_svector *xh, diff --git a/cbind/linsolve/psb_slinsolve_cbind_mod.f90 b/cbind/linsolve/psb_slinsolve_cbind_mod.f90 index e1823bd8..5a2c064b 100644 --- a/cbind/linsolve/psb_slinsolve_cbind_mod.f90 +++ b/cbind/linsolve/psb_slinsolve_cbind_mod.f90 @@ -32,6 +32,7 @@ contains function psb_c_skrylov_opt(methd,& & ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res) use psb_base_mod + use psb_error_mod use psb_prec_mod use psb_linsolve_mod use psb_objhandle_mod @@ -53,7 +54,7 @@ contains type(psb_sprec_type), pointer :: precp type(psb_s_vect_type), pointer :: xp, bp - integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter + integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act character(len=20) :: fmethd real(psb_spk_) :: feps,ferr @@ -91,7 +92,8 @@ contains fitrace = itrace first = irst fistop = istop - + err_act = psb_act_abort_ + if (psb_errstatus_fatal()) call psb_error_handler(err_act) call psb_krylov(fmethd, ap, precp, bp, xp, feps, & & descp, info,& & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,& @@ -99,6 +101,7 @@ contains iter = fiter err = ferr res = info + if (psb_errstatus_fatal()) call psb_error_handler(err_act) end function psb_c_skrylov_opt diff --git a/cbind/linsolve/psb_zlinsolve_cbind_mod.f90 b/cbind/linsolve/psb_zlinsolve_cbind_mod.f90 index 3234c72c..a95d7f96 100644 --- a/cbind/linsolve/psb_zlinsolve_cbind_mod.f90 +++ b/cbind/linsolve/psb_zlinsolve_cbind_mod.f90 @@ -32,6 +32,7 @@ contains function psb_c_zkrylov_opt(methd,& & ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res) use psb_base_mod + use psb_error_mod use psb_prec_mod use psb_linsolve_mod use psb_objhandle_mod @@ -53,7 +54,7 @@ contains type(psb_zprec_type), pointer :: precp type(psb_z_vect_type), pointer :: xp, bp - integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter + integer(psb_c_ipk_) :: info,fitmax,fitrace,first,fistop,fiter,err_act character(len=20) :: fmethd real(psb_dpk_) :: feps,ferr @@ -91,7 +92,8 @@ contains fitrace = itrace first = irst fistop = istop - + err_act = psb_act_abort_ + if (psb_errstatus_fatal()) call psb_error_handler(err_act) call psb_krylov(fmethd, ap, precp, bp, xp, feps, & & descp, info,& & itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,& @@ -99,6 +101,7 @@ contains iter = fiter err = ferr res = info + if (psb_errstatus_fatal()) call psb_error_handler(err_act) end function psb_c_zkrylov_opt diff --git a/prec/impl/psb_c_bjacprec_impl.f90 b/prec/impl/psb_c_bjacprec_impl.f90 index 59b01933..c2f9d510 100644 --- a/prec/impl/psb_c_bjacprec_impl.f90 +++ b/prec/impl/psb_c_bjacprec_impl.f90 @@ -644,6 +644,10 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) enddo deallocate(prec%av,stat=info) endif + if (allocated (prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv) + end if end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) diff --git a/prec/impl/psb_c_diagprec_impl.f90 b/prec/impl/psb_c_diagprec_impl.f90 index 4e7c766a..296fe8e2 100644 --- a/prec/impl/psb_c_diagprec_impl.f90 +++ b/prec/impl/psb_c_diagprec_impl.f90 @@ -270,7 +270,7 @@ subroutine psb_c_diag_precbld(a,desc_a,prec,info,amold,vmold,imold) prec%d(i) = cone end do - allocate(prec%dv,stat=info) + if (.not.allocated(prec%dv)) allocate(prec%dv,stat=info) if (info == 0) then if (present(vmold)) then allocate(prec%dv%v,mold=vmold,stat=info) diff --git a/prec/impl/psb_d_bjacprec_impl.f90 b/prec/impl/psb_d_bjacprec_impl.f90 index 9f5b75a7..e0eaa5be 100644 --- a/prec/impl/psb_d_bjacprec_impl.f90 +++ b/prec/impl/psb_d_bjacprec_impl.f90 @@ -644,6 +644,10 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) enddo deallocate(prec%av,stat=info) endif + if (allocated (prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv) + end if end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) diff --git a/prec/impl/psb_d_diagprec_impl.f90 b/prec/impl/psb_d_diagprec_impl.f90 index ec624908..695f4887 100644 --- a/prec/impl/psb_d_diagprec_impl.f90 +++ b/prec/impl/psb_d_diagprec_impl.f90 @@ -270,7 +270,7 @@ subroutine psb_d_diag_precbld(a,desc_a,prec,info,amold,vmold,imold) prec%d(i) = done end do - allocate(prec%dv,stat=info) + if (.not.allocated(prec%dv)) allocate(prec%dv,stat=info) if (info == 0) then if (present(vmold)) then allocate(prec%dv%v,mold=vmold,stat=info) diff --git a/prec/impl/psb_s_bjacprec_impl.f90 b/prec/impl/psb_s_bjacprec_impl.f90 index a477c663..405c9ad5 100644 --- a/prec/impl/psb_s_bjacprec_impl.f90 +++ b/prec/impl/psb_s_bjacprec_impl.f90 @@ -644,6 +644,10 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) enddo deallocate(prec%av,stat=info) endif + if (allocated (prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv) + end if end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) diff --git a/prec/impl/psb_s_diagprec_impl.f90 b/prec/impl/psb_s_diagprec_impl.f90 index 8e93f964..7ad4785d 100644 --- a/prec/impl/psb_s_diagprec_impl.f90 +++ b/prec/impl/psb_s_diagprec_impl.f90 @@ -270,7 +270,7 @@ subroutine psb_s_diag_precbld(a,desc_a,prec,info,amold,vmold,imold) prec%d(i) = sone end do - allocate(prec%dv,stat=info) + if (.not.allocated(prec%dv)) allocate(prec%dv,stat=info) if (info == 0) then if (present(vmold)) then allocate(prec%dv%v,mold=vmold,stat=info) diff --git a/prec/impl/psb_z_bjacprec_impl.f90 b/prec/impl/psb_z_bjacprec_impl.f90 index 91e833a4..375241a6 100644 --- a/prec/impl/psb_z_bjacprec_impl.f90 +++ b/prec/impl/psb_z_bjacprec_impl.f90 @@ -644,6 +644,10 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) enddo deallocate(prec%av,stat=info) endif + if (allocated (prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv) + end if end if if (.not.allocated(prec%av)) then allocate(prec%av(psb_max_avsz),stat=info) diff --git a/prec/impl/psb_z_diagprec_impl.f90 b/prec/impl/psb_z_diagprec_impl.f90 index 6940af2a..4bc7ce61 100644 --- a/prec/impl/psb_z_diagprec_impl.f90 +++ b/prec/impl/psb_z_diagprec_impl.f90 @@ -270,7 +270,7 @@ subroutine psb_z_diag_precbld(a,desc_a,prec,info,amold,vmold,imold) prec%d(i) = zone end do - allocate(prec%dv,stat=info) + if (.not.allocated(prec%dv)) allocate(prec%dv,stat=info) if (info == 0) then if (present(vmold)) then allocate(prec%dv%v,mold=vmold,stat=info)