From 8eae0dc4597d0018de4b694b18cd6dc58a99672f Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Fri, 8 May 2020 12:13:42 +0200 Subject: [PATCH] Corrected return on C interface of precinit for already associated prec --- cbind/mlprec/mld_dprec_cbind_mod.F90 | 183 +++++++++++++-------------- cbind/mlprec/mld_zprec_cbind_mod.F90 | 183 +++++++++++++-------------- 2 files changed, 182 insertions(+), 184 deletions(-) diff --git a/cbind/mlprec/mld_dprec_cbind_mod.F90 b/cbind/mlprec/mld_dprec_cbind_mod.F90 index 062597fa..b9260f60 100644 --- a/cbind/mlprec/mld_dprec_cbind_mod.F90 +++ b/cbind/mlprec/mld_dprec_cbind_mod.F90 @@ -8,7 +8,7 @@ module mld_dprec_cbind_mod type(c_ptr) :: item = c_null_ptr end type mld_c_dprec -contains +contains #if 1 #define MLDC_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG @@ -21,13 +21,13 @@ contains !#define MLDC_ERR_FILTER(INFO) min(0,INFO) #define MLDC_ERR_FILTER(INFO) (INFO) #define MLDC_ERR_HANDLE(INFO) if(INFO/=mld_success_)MLDC_ERROR("ERROR!") - + function mld_c_dprecinit(ictxt,ph,ptype) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(mld_c_dprec) :: ph integer(psb_c_ipk_), value :: ictxt character(c_char) :: ptype(*) @@ -36,20 +36,20 @@ contains character(len=80) :: fptype res = -1 - res = -1 - if (c_associated(ph%item)) then - return + if (c_associated(ph%item)) then + res = 0 + return end if allocate(precp,stat=info) if (info /= 0) return - + ph%item = c_loc(precp) call stringc2f(ptype,fptype) - - call precp%init(ictxt,fptype,info) - + + call precp%init(ictxt,fptype,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return @@ -58,9 +58,9 @@ contains function mld_c_dprecseti(ph,what,val) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph character(c_char) :: what(*) integer(psb_c_ipk_), value :: val @@ -69,28 +69,28 @@ contains type(mld_dprec_type), pointer :: precp res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if call stringc2f(what,fwhat) - call mld_precset(precp,fwhat,val,info) - + call mld_precset(precp,fwhat,val,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_dprecseti - + function mld_c_dprecsetr(ph,what,val) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph character(c_char) :: what(*) real(c_double), value :: val @@ -99,27 +99,27 @@ contains type(mld_dprec_type), pointer :: precp res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if call stringc2f(what,fwhat) - call mld_precset(precp,fwhat,val,info) - + call mld_precset(precp,fwhat,val,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_dprecsetr - + function mld_c_dprecsetc(ph,what,val) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph character(c_char) :: what(*), val(*) integer :: info @@ -127,17 +127,17 @@ contains type(mld_dprec_type), pointer :: precp res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if call stringc2f(what,fwhat) call stringc2f(val,fval) - call mld_precset(precp,fwhat,fval,info) - + call mld_precset(precp,fwhat,fval,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return @@ -146,9 +146,9 @@ contains function mld_c_dprecbld(ah,cdh,ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph,ah,cdh integer :: info type(mld_dprec_type), pointer :: precp @@ -158,36 +158,36 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - call mld_precbld(ap,descp,precp,info) + call mld_precbld(ap,descp,precp,info) res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_dprecbld - + function mld_c_dhierarchy_build(ah,cdh,ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph,ah,cdh integer :: info type(mld_dprec_type), pointer :: precp @@ -197,23 +197,23 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - call precp%hierarchy_build(ap,descp,info) + call precp%hierarchy_build(ap,descp,info) res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) @@ -224,9 +224,9 @@ contains function mld_c_dsmoothers_build(ah,cdh,ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph,ah,cdh integer :: info type(mld_dprec_type), pointer :: precp @@ -236,30 +236,30 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - call precp%smoothers_build(ap,descp,info) + call precp%smoothers_build(ap,descp,info) res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_dsmoothers_build - + function mld_c_dkrylov(methd,& & ah,ph,bh,xh,cdh,options) bind(c) result(res) use psb_base_mod @@ -267,17 +267,17 @@ contains use psb_krylov_mod use psb_prec_cbind_mod use psb_dkrylov_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ah,cdh,ph,bh,xh character(c_char) :: methd(*) type(solveroptions) :: options - + res= mld_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) - + end function mld_c_dkrylov @@ -289,7 +289,7 @@ contains use psb_objhandle_mod use psb_prec_cbind_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ah,cdh,ph,bh,xh integer(psb_c_ipk_), value :: itmax,itrace,irst,istop @@ -307,33 +307,33 @@ contains real(kind(1.d0)) :: feps,ferr res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(bh%item)) then + if (c_associated(bh%item)) then call c_f_pointer(bh%item,bp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - + call stringc2f(methd,fmethd) feps = eps fitmax = itmax @@ -348,34 +348,33 @@ contains iter = fiter err = ferr res = min(info,0) - + end function mld_c_dkrylov_opt function mld_c_dprecfree(ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph integer :: info type(mld_dprec_type), pointer :: precp character(len=80) :: fptype res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - - call precp%free(info) - + + call precp%free(info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_dprecfree end module mld_dprec_cbind_mod - diff --git a/cbind/mlprec/mld_zprec_cbind_mod.F90 b/cbind/mlprec/mld_zprec_cbind_mod.F90 index 906bbead..ffcfeb2c 100644 --- a/cbind/mlprec/mld_zprec_cbind_mod.F90 +++ b/cbind/mlprec/mld_zprec_cbind_mod.F90 @@ -8,7 +8,7 @@ module mld_zprec_cbind_mod type(c_ptr) :: item = c_null_ptr end type mld_c_zprec -contains +contains #if 1 #define MLDC_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG @@ -21,13 +21,13 @@ contains !#define MLDC_ERR_FILTER(INFO) min(0,INFO) #define MLDC_ERR_FILTER(INFO) (INFO) #define MLDC_ERR_HANDLE(INFO) if(INFO/=mld_success_)MLDC_ERROR("ERROR!") - + function mld_c_zprecinit(ictxt,ph,ptype) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(mld_c_zprec) :: ph integer(psb_c_ipk_), value :: ictxt character(c_char) :: ptype(*) @@ -36,20 +36,20 @@ contains character(len=80) :: fptype res = -1 - res = -1 - if (c_associated(ph%item)) then - return + if (c_associated(ph%item)) then + res = 0 + return end if allocate(precp,stat=info) if (info /= 0) return - + ph%item = c_loc(precp) call stringc2f(ptype,fptype) - - call precp%init(ictxt,fptype,info) - + + call precp%init(ictxt,fptype,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return @@ -58,9 +58,9 @@ contains function mld_c_zprecseti(ph,what,val) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph character(c_char) :: what(*) integer(psb_c_ipk_), value :: val @@ -69,28 +69,28 @@ contains type(mld_zprec_type), pointer :: precp res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if call stringc2f(what,fwhat) - call mld_precset(precp,fwhat,val,info) - + call mld_precset(precp,fwhat,val,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_zprecseti - + function mld_c_zprecsetr(ph,what,val) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph character(c_char) :: what(*) real(c_double), value :: val @@ -99,27 +99,27 @@ contains type(mld_zprec_type), pointer :: precp res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if call stringc2f(what,fwhat) - call mld_precset(precp,fwhat,val,info) - + call mld_precset(precp,fwhat,val,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_zprecsetr - + function mld_c_zprecsetc(ph,what,val) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph character(c_char) :: what(*), val(*) integer :: info @@ -127,17 +127,17 @@ contains type(mld_zprec_type), pointer :: precp res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if call stringc2f(what,fwhat) call stringc2f(val,fval) - call mld_precset(precp,fwhat,fval,info) - + call mld_precset(precp,fwhat,fval,info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return @@ -146,9 +146,9 @@ contains function mld_c_zprecbld(ah,cdh,ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph,ah,cdh integer :: info type(mld_zprec_type), pointer :: precp @@ -158,36 +158,36 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - call mld_precbld(ap,descp,precp,info) + call mld_precbld(ap,descp,precp,info) res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_zprecbld - + function mld_c_zhierarchy_build(ah,cdh,ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph,ah,cdh integer :: info type(mld_zprec_type), pointer :: precp @@ -197,23 +197,23 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - call precp%hierarchy_build(ap,descp,info) + call precp%hierarchy_build(ap,descp,info) res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) @@ -224,9 +224,9 @@ contains function mld_c_zsmoothers_build(ah,cdh,ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph,ah,cdh integer :: info type(mld_zprec_type), pointer :: precp @@ -236,30 +236,30 @@ contains res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - call precp%smoothers_build(ap,descp,info) + call precp%smoothers_build(ap,descp,info) res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_zsmoothers_build - + function mld_c_zkrylov(methd,& & ah,ph,bh,xh,cdh,options) bind(c) result(res) use psb_base_mod @@ -267,17 +267,17 @@ contains use psb_krylov_mod use psb_prec_cbind_mod use psb_zkrylov_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ah,cdh,ph,bh,xh character(c_char) :: methd(*) type(solveroptions) :: options - + res= mld_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) - + end function mld_c_zkrylov @@ -289,7 +289,7 @@ contains use psb_objhandle_mod use psb_prec_cbind_mod use psb_base_string_cbind_mod - implicit none + implicit none integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ah,cdh,ph,bh,xh integer(psb_c_ipk_), value :: itmax,itrace,irst,istop @@ -307,33 +307,33 @@ contains real(kind(1.d0)) :: feps,ferr res = -1 - if (c_associated(cdh%item)) then + if (c_associated(cdh%item)) then call c_f_pointer(cdh%item,descp) else - return + return end if - if (c_associated(xh%item)) then + if (c_associated(xh%item)) then call c_f_pointer(xh%item,xp) else - return + return end if - if (c_associated(bh%item)) then + if (c_associated(bh%item)) then call c_f_pointer(bh%item,bp) else - return + return end if - if (c_associated(ah%item)) then + if (c_associated(ah%item)) then call c_f_pointer(ah%item,ap) else - return + return end if - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - + call stringc2f(methd,fmethd) feps = eps fitmax = itmax @@ -348,34 +348,33 @@ contains iter = fiter err = ferr res = min(info,0) - + end function mld_c_zkrylov_opt function mld_c_zprecfree(ph) bind(c) result(res) use psb_base_mod use mld_prec_mod - implicit none - - integer(psb_c_ipk_) :: res + implicit none + + integer(psb_c_ipk_) :: res type(psb_c_object_type) :: ph integer :: info type(mld_zprec_type), pointer :: precp character(len=80) :: fptype res = -1 - if (c_associated(ph%item)) then + if (c_associated(ph%item)) then call c_f_pointer(ph%item,precp) else - return + return end if - - call precp%free(info) - + + call precp%free(info) + res = MLDC_ERR_FILTER(info) MLDC_ERR_HANDLE(res) return end function mld_c_zprecfree end module mld_zprec_cbind_mod -