Compare commits

...
20 changed files with 194 additions and 55 deletions
+5
View File
@@ -636,6 +636,11 @@ contains
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
if (psb_errstatus_fatal()) then
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
end do
deallocate(prec%precv,stat=info)
end if
+5
View File
@@ -636,6 +636,11 @@ contains
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
if (psb_errstatus_fatal()) then
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
end do
deallocate(prec%precv,stat=info)
end if
+5
View File
@@ -636,6 +636,11 @@ contains
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
if (psb_errstatus_fatal()) then
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
end do
deallocate(prec%precv,stat=info)
end if
+5
View File
@@ -636,6 +636,11 @@ contains
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
if (psb_errstatus_fatal()) then
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
end do
deallocate(prec%precv,stat=info)
end if
@@ -100,6 +100,10 @@ subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = cone/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -103,6 +103,10 @@ subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = cone/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -100,6 +100,10 @@ subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = done/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -103,6 +103,10 @@ subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = done/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -100,6 +100,10 @@ subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = sone/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -103,6 +103,10 @@ subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = sone/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -100,6 +100,10 @@ subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = zone/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
@@ -103,6 +103,10 @@ subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
sv%d(i) = zone/sv%d(i)
end if
end do
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
allocate(sv%dv,stat=info)
if (info == psb_success_) then
call sv%dv%bld(sv%d)
+3 -2
View File
@@ -36,8 +36,9 @@ extern "C" {
psb_i_t amg_c_dallocate_wrk(amg_c_dprec *ph, const char *chfmt);
psb_i_t amg_c_dkrylov(const char *method, psb_c_dspmat *ah, amg_c_dprec *ph,
psb_c_dvector *bh, psb_c_dvector *xh,
psb_c_descriptor *cdh, psb_c_SolverOptions *opt);
psb_c_dvector *bh, psb_c_dvector *xh,
psb_c_descriptor *cdh, psb_c_dvector *s1,
psb_c_dvector *s2, psb_c_SolverOptions *opt);
#ifdef __cplusplus
+2 -1
View File
@@ -40,7 +40,8 @@ extern "C"
psb_i_t amg_c_zkrylov(const char *method, psb_c_zspmat *ah, amg_c_zprec *ph,
psb_c_zvector *bh, psb_c_zvector *xh,
psb_c_descriptor *cdh, psb_c_SolverOptions *opt);
psb_c_descriptor *cdh, , psb_c_zvector *s1,
psb_c_zvector *s2, psb_c_SolverOptions *opt);
#ifdef __cplusplus
}
+56 -16
View File
@@ -3,6 +3,7 @@ module amg_dprec_cbind_mod
use iso_c_binding
use amg_prec_mod
use psb_base_cbind_mod
use psb_dlinsolve_cbind_mod
type, bind(c) :: amg_c_dprec
type(c_ptr) :: item = c_null_ptr
@@ -172,15 +173,17 @@ contains
end function amg_c_dprecbld
function amg_c_dhierarchy_build(ah,cdh,ph) bind(c) result(res)
use psb_base_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ph,ah,cdh
integer(psb_ipk_) :: iret
type(amg_dprec_type), pointer :: precp
type(psb_dspmat_type), pointer :: ap
type(psb_desc_type), pointer :: descp
character(len=80) :: fptype
integer(psb_ipk_) :: iret, act
res = -1
@@ -204,11 +207,16 @@ contains
res = AMGC_ERR_FILTER(iret)
AMGC_ERR_HANDLE(res)
if (res /=0) then
act = psb_act_abort_
call psb_error_handler(act)
end if
return
end function amg_c_dhierarchy_build
function amg_c_dsmoothers_build(ah,cdh,ph) bind(c) result(res)
use psb_base_mod
implicit none
integer(psb_c_ipk_) :: res
@@ -217,7 +225,7 @@ contains
type(psb_dspmat_type), pointer :: ap
type(psb_desc_type), pointer :: descp
character(len=80) :: fptype
integer(psb_ipk_) :: iret
integer(psb_ipk_) :: iret, act
res = -1
@@ -241,8 +249,10 @@ contains
res = AMGC_ERR_FILTER(iret)
AMGC_ERR_HANDLE(res)
return
if (res /=0) then
act = psb_act_abort_
call psb_error_handler(act)
end if
end function amg_c_dsmoothers_build
function amg_c_dsmoothers_build_opt(ah,cdh,ph,afmt,cdfmt) bind(c) result(res)
@@ -360,7 +370,7 @@ contains
end function amg_c_dsmoothers_build_opt
function amg_c_dkrylov(methd,&
& ah,ph,bh,xh,cdh,options) bind(c) result(res)
& ah,ph,bh,xh,cdh,s1,s2,options) bind(c) result(res)
use psb_base_mod
use psb_prec_mod
use psb_linsolve_mod
@@ -368,20 +378,21 @@ contains
use psb_dlinsolve_cbind_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1,s2
character(c_char) :: methd(*)
type(solveroptions) :: options
res= amg_c_dkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
& itmax=options%itmax, iter=options%iter,&
& itrace=options%itrace, istop=options%istop,&
& irst=options%irst, err=options%err)
& irst=options%irst, err=options%err, s1=s1,s2=s2)
end function amg_c_dkrylov
function amg_c_dkrylov_opt(methd,&
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,&
& itrace,irst,istop,s1,s2) bind(c) result(res)
use psb_base_mod
use psb_prec_mod
use psb_linsolve_mod
@@ -389,16 +400,17 @@ contains
use psb_prec_cbind_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1, s2
integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
real(c_double), value :: eps
integer(psb_c_ipk_) :: iter
real(c_double) :: err
character(c_char) :: methd(*)
type(psb_desc_type), pointer :: descp
type(psb_dspmat_type), pointer :: ap
type(amg_dprec_type), pointer :: precp
type(psb_d_vect_type), pointer :: xp, bp
type(psb_d_vect_type), pointer :: xp, bp, s1p, s2p
integer(psb_ipk_) :: iret,fitmax,fitrace,first,fistop,fiter
character(len=20) :: fmethd
@@ -431,6 +443,16 @@ contains
return
end if
if (c_associated(s1%item)) then
call c_f_pointer(s1%item,s1p)
else
nullify(s1p)
end if
if (c_associated(s2%item)) then
call c_f_pointer(s2%item,s2p)
else
nullify(s2p)
end if
call psb_stringc2f(methd,fmethd)
feps = eps
@@ -439,10 +461,28 @@ contains
first = irst
fistop = istop
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
if (associated(s1p).and.associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p,s2=s2p)
else if (associated(s1p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p)
else if (associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s2=s2p)
else
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
end if
iter = fiter
err = ferr
res = min(iret,0)
@@ -497,7 +537,7 @@ contains
res = AMGC_ERR_FILTER(info)
AMGC_ERR_HANDLE(res)
return
end function amg_c_dprecapply
end function amg_c_dprecapply
function amg_c_dprecapply_opt(ph,bc,xc,cdh,ctrans) bind(c,name="amg_c_dprecapply_opt") result(res)
use psb_base_mod
@@ -553,7 +593,7 @@ end function amg_c_dprecapply
res = AMGC_ERR_FILTER(info)
AMGC_ERR_HANDLE(res)
return
end function amg_c_dprecapply_opt
end function amg_c_dprecapply_opt
function amg_c_dprecfree(ph) bind(c) result(res)
implicit none
+61 -16
View File
@@ -140,11 +140,11 @@ contains
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ph,ah,cdh
integer(psb_ipk_) :: iret
type(amg_zprec_type), pointer :: precp
type(psb_zspmat_type), pointer :: ap
type(psb_desc_type), pointer :: descp
character(len=80) :: fptype
integer(psb_ipk_) :: iret
res = -1
@@ -173,15 +173,17 @@ contains
end function amg_c_zprecbld
function amg_c_zhierarchy_build(ah,cdh,ph) bind(c) result(res)
use psb_base_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ph,ah,cdh
integer(psb_ipk_) :: iret
type(amg_zprec_type), pointer :: precp
type(psb_zspmat_type), pointer :: ap
type(psb_desc_type), pointer :: descp
character(len=80) :: fptype
integer(psb_ipk_) :: iret, act
res = -1
@@ -205,20 +207,25 @@ contains
res = AMGC_ERR_FILTER(iret)
AMGC_ERR_HANDLE(res)
if (res /=0) then
act = psb_act_abort_
call psb_error_handler(act)
end if
return
end function amg_c_zhierarchy_build
function amg_c_zsmoothers_build(ah,cdh,ph) bind(c) result(res)
use psb_base_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ph,ah,cdh
integer(psb_ipk_) :: iret
type(amg_zprec_type), pointer :: precp
type(psb_zspmat_type), pointer :: ap
type(psb_desc_type), pointer :: descp
character(len=80) :: fptype
integer(psb_ipk_) :: iret, act
res = -1
@@ -242,11 +249,15 @@ contains
res = AMGC_ERR_FILTER(iret)
AMGC_ERR_HANDLE(res)
if (res /=0) then
act = psb_act_abort_
call psb_error_handler(act)
end if
return
end function amg_c_zsmoothers_build
function amg_c_zsmoothers_build_format(ah,cdh,ph,afmt,cdfmt) bind(c) result(res)
function amg_c_zsmoothers_build_opt(ah,cdh,ph,afmt,cdfmt) bind(c) result(res)
#if defined (PSB_HAVE_CUDA)
use psb_cuda_mod
#endif
@@ -352,34 +363,40 @@ contains
AMGC_ERR_HANDLE(res)
return
end function amg_c_zsmoothers_build_format
end function amg_c_zsmoothers_build_opt
function amg_c_zkrylov(methd,&
& ah,ph,bh,xh,cdh,options) bind(c) result(res)
& ah,ph,bh,xh,cdh,s1,s2,options) bind(c) result(res)
use psb_base_mod
use psb_prec_mod
use psb_linsolve_mod
use psb_prec_cbind_mod
use psb_zlinsolve_cbind_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1,s2
character(c_char) :: methd(*)
type(solveroptions) :: options
res= amg_c_zkrylov_opt(methd, ah, ph, bh, xh, options%eps,cdh, &
& itmax=options%itmax, iter=options%iter,&
& itrace=options%itrace, istop=options%istop,&
& irst=options%irst, err=options%err)
& irst=options%irst, err=options%err, s1=s1,s2=s2)
end function amg_c_zkrylov
function amg_c_zkrylov_opt(methd,&
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,itrace,irst,istop) bind(c) result(res)
& ah,ph,bh,xh,eps,cdh,itmax,iter,err,&
& itrace,irst,istop,s1,s2) bind(c) result(res)
use psb_base_mod
use psb_prec_mod
use psb_linsolve_mod
use psb_objhandle_mod
use psb_prec_cbind_mod
implicit none
integer(psb_c_ipk_) :: res
type(psb_c_object_type) :: ah,cdh,ph,bh,xh
type(psb_c_object_type) :: ah,cdh,ph,bh,xh,s1, s2
integer(psb_c_ipk_), value :: itmax,itrace,irst,istop
real(c_double), value :: eps
integer(psb_c_ipk_) :: iter
@@ -388,7 +405,7 @@ contains
type(psb_desc_type), pointer :: descp
type(psb_zspmat_type), pointer :: ap
type(amg_zprec_type), pointer :: precp
type(psb_z_vect_type), pointer :: xp, bp
type(psb_z_vect_type), pointer :: xp, bp, s1p, s2p
integer(psb_ipk_) :: iret,fitmax,fitrace,first,fistop,fiter
character(len=20) :: fmethd
@@ -420,6 +437,16 @@ contains
else
return
end if
if (c_associated(s1%item)) then
call c_f_pointer(s1%item,s1p)
else
nullify(s1p)
end if
if (c_associated(s2%item)) then
call c_f_pointer(s2%item,s2p)
else
nullify(s2p)
end if
call psb_stringc2f(methd,fmethd)
@@ -429,10 +456,28 @@ contains
first = irst
fistop = istop
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
if (associated(s1p).and.associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p,s2=s2p)
else if (associated(s1p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s1=s1p)
else if (associated(s2p)) then
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr,s2=s2p)
else
call psb_krylov(fmethd, ap, precp, bp, xp, feps, &
& descp, iret,&
& itmax=fitmax,iter=fiter,itrace=fitrace,istop=fistop,&
& irst=first, err=ferr)
end if
iter = fiter
err = ferr
res = min(iret,0)
+7 -7
View File
@@ -176,7 +176,7 @@ contains
else
partition_ = 3
end if
deltah = done/(idim+2)
deltah = done/(idim+1)
sqdeltah = deltah*deltah
deltah2 = 2.0_psb_dpk_* deltah
@@ -412,9 +412,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
!
@@ -643,7 +643,7 @@ contains
f_ => d_null_func_2d
end if
deltah = done/(idim+2)
deltah = done/(idim+1)
sqdeltah = deltah*deltah
deltah2 = 2.0_psb_dpk_* deltah
@@ -875,8 +875,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
+7 -7
View File
@@ -176,7 +176,7 @@ contains
else
partition_ = 3
end if
deltah = sone/(idim+2)
deltah = sone/(idim+1)
sqdeltah = deltah*deltah
deltah2 = 2.0_psb_spk_* deltah
@@ -412,9 +412,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
!
@@ -643,7 +643,7 @@ contains
f_ => s_null_func_2d
end if
deltah = sone/(idim+2)
deltah = sone/(idim+1)
sqdeltah = deltah*deltah
deltah2 = 2.0_psb_spk_* deltah
@@ -875,8 +875,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
+3 -3
View File
@@ -369,9 +369,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
!
+3 -3
View File
@@ -369,9 +369,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
!